packages feed

hdirect (empty) → 0.21.0

raw patch · 149 files changed

+64964/−0 lines, 149 filesdep +arraydep +basedep +haskell98setup-changed

Dependencies added: array, base, haskell98, pretty

Files

+ ANNOUNCE view
@@ -0,0 +1,100 @@+	 HaskellDirect - an IDL compiler for Haskell
+
+A new release of HaskellDirect, version 0.16, is now available
+for download (source + binaries.) 
+
+* What is it?
+=============
+
+HaskellDirect is an IDL compiler for Haskell, helping to bridge the
+gap between Haskell programs and the outside world. Interfacing
+Haskell code to libraries or components written in other languages
+involves the conversion of values between the Haskell representations
+of values and the representations expected externally. Using an Interface
+Definition Language (IDL) as basis, HaskellDirect automates the generation
+of such impedance matching code, leaving you to focus on how to implement
+the Interesting Bits.
+
+HaskellDirect supports the OSF DCE and OMG CORBA dialects of
+IDL. Notice that DCE IDL is a superset of C function prototype and
+type declarations.  So, by implication, HaskellDirect will also accept
+C header files as input.
+
+* What's new?
+=============
+
+Version 0.16 adds the following:
+
+* Lambada support - support for generating Haskell-callable stubs
+  to Java objects. Going the other way is also supported - automatic
+  generation of Java-callable wrappers to Haskell functions.
+* Improved support for working with C header files:
+     * off-line configuration of IDL/marshalling attributes.
+       (i.e., no need to manually modify your header files.)
+     * selective generation of stubs, pick out the functions you're
+       interested in (and ignore the rest.)
+* Better support for one-Haskell-module-per-interface/ADT mapping;
+  the compiler now tries to avoid generating mutually recursive Haskell
+  modules, if possible.
+
+* Improved set of support libraries.
+
+* New examples:
+
+     * PCRE - generate Haskell binding to PCRE (Perl-Compatible
+       Regular Expression)
+     * ActiveX scripting engine - basic demonstration of how to write
+       a scripting engine in Haskell, which you can then use inside
+       web pages, with ASP etc.
+     * perl - generate Haskell binding to libperl, letting you call
+       out to Perl code from Haskell.
+     * HTML dialogs - use IE's support for creating HTML-based modal
+       dialogs.
+     * Video/Audio player - COM client example.
+     * zlib - Haskell binding to zlib compression library (also in 0.15.)
+     * gd   - Haskell binding to GD Gif manip. library  (also in 0.15.)
+     * ie-listen - interact with IE from Haskell (also in 0.15.)
+
+ * Works with ghc-4.04 and Hugs98 (and HaskellScript.)
+
+ * Due to time constraints (& the author moving job), 0.16 does *unfortunately*
+   not include (semi-promised) CORBA support. 
+
+Version 0.15 adds the following:
+
+* Haskell COM component support (vtbl-based and Automation).
+* Haskell library support - package up your Haskell code
+  and give it to your C, Java etc. friends to use.
+* More comprehensive marshaling support (function types are now
+  handled).
+* Support for creating COM type libraries as well as an improved
+  type library reader.
+* native Hugs98 support.
+* support for generating C header files from IDL specs.
+* Extensions and bugfixes too numerous to mention ; consult
+  user documentation for details.
+* Graphical user interface - desktop launcher (Win32 only).
+* Wizardly generation of skeleton component implementations
+  (if you ask nicely.)
+* a Y2K bug.
+
+* More information
+==================
+
+Pointers to a downloadable distribution, documentation etc.  is
+now available via the HaskellDirect home page:
+
+   http://www.dcs.gla.ac.uk/fp/software/hdirect/
+
+To compile up HaskellDirect from source you'll need to have GHC 4.04
+(or later) installed on your machine. To use the generated output,
+you'll either need GHC-4.04 or Hugs98 / HaskellScript.
+
+* Bug reports/feedback
+======================
+
+Please send any bug reports or suggestions for how to improve
+HaskellDirect to the Glasgow Haskell Bugs list:
+glasgow-haskell-bugs@haskell.org 
+
+Enjoy!
+ INSTALL view
@@ -0,0 +1,58 @@+** Building and installing HaskellDirect
+
+1. Unpack the source distribution somewhere convenient
+   and edit 'config.mk' at the top of the distribution.
+   You'll need to supply the following:
+
+     - HC -- the Haskell compiler to use [default: 'ghc']
+
+2. Run 'make boot' from the toplevel HaskellDirect directory,
+   followed by 'make'  (where 'make' == GNU make.)
+
+3. Upon completion, run 'make lib' from the toplevel, which'll
+   compile up the support libraries for both Hugs98 and GHC.
+   
+4. Assuming the last two steps completed successfully,
+   that's it - you're now set to start using the IDL compiler.
+
+   The examples/ directory contains, as you've probably guessed,
+   some examples. See examples/README for overview of what the
+   individual examples do.
+
+   For the examples that work with both Hugs and GHC, you will
+   need to invoke "make" as follows to build the Hugs version
+   of the example
+
+            make FOR_HUGS=YES
+
+Extra goodies:
+ 
+- to install the HDirect libraries (the generic and/or the COM
+  specific ones) as GHC packages, you need to 'cd' into lib
+  (and comlib/, if needs be), and 'make install-pkg'. This rule
+  assumes that GHC_PKG refers to the ghc_pkg util that goes with
+  the HC you configured in config.mk
+  
+  Upon successful completion, the generic HDirect libraries will
+  be available as package 'hdirect', and the COM libraries as 'com'.
+
+  The packages are useable from within GHCi and in batch-mode.
+
+- to have HDirect support the reading (and writing) of COM type
+  libraries, you need to 'make' src/ with SUPPORT_TYPELIBS=YES.
+  This assumes that you already have a compiled up version of the
+  HDirect COM library, which you clearly won't have initially.
+  Hence, you need to either do a second clean build of the
+  HDirect sources, or just make sure you re-make src/ after
+  having built comlib/...here's how to do the latter:
+  
+    ...unpack sources and tailor config.mk ..
+    foo$ make
+    ..
+    foo$ make lib
+    foo$ cd comlib/
+    foo$ make install-pkg GHC_PKG=/path/to/your/ghc/bin/ghc-pkg
+    foo$ cd ../src
+    foo$ rm -f *.o
+    foo$ make depend SUPPORT_TYPELIBS=YES
+    foo$ make SUPPORT_TYPELIBS=YES
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 1998-99 University of Glasgow and Sigbjorn Finne.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright notice,
+  this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+  notice, this list of conditions and the following disclaimer in the
+  documentation and/or other materials provided with the distribution.
+
+- Neither name of the copyright holders nor the names of its
+  contributors may be used to endorse or promote products derived from
+  this software without specific prior written permission.
+  
+THIS SOFTWARE IS PROVIDED BY THE COPYIGHT HOLDERS AND CONTRIBUTORS
+``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
+OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
+TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.
+ Makefile view
@@ -0,0 +1,15 @@+# Toplevel Makefile for HaskellDirect
+TOP=.
+include $(TOP)/mk/boilerplate.mk
+
+all ::
+
+SUBDIRS = src
+
+lib ::
+	$(MAKE) -C lib boot && $(MAKE) -C lib all
+ifeq "$(FOR_WIN32)" "YES"
+	$(MAKE) -C comlib boot && $(MAKE) -C comlib all
+endif
+
+include $(TOP)/mk/target.mk
+ NEWS view
@@ -0,0 +1,34 @@+** Major changes in hdirect version 0.17:
+
+* Nothing major, just a couple of bugfixes and
+  improvements.
+
+** Major changes in hdirect version 0.16:
+
+* Support for generating TLBs, Com servers, header
+  file reading, multi-module support.
+
+** Major changes in hdirect version 0.14:
+
+* Fixed bug in the marshalling(&freeing) of
+  dependent arguments. (Thanks to Michael Hobbs
+  <hobb0001@tc.umn.edu> for reporting this.)
+
+* Minor bugfixes to library code.
+
+** Major changes in hdirect version 0.13:
+
+* [Win32 specific]: Integrated Daan Leijen's
+  Red Card code for reading type libraries
+  (compiled representations of IDL.)
+
+* Added support for nameless unions. 
+
+* Recursive types should now be handled a great
+  deal better.
+
+* [For HaskellScript users]: New option,
+  -fautomation, packages up commonly used options
+  when generating Automation-stubs.
+
+* Fixed a whole raft of minor bugs.
+ README view
@@ -0,0 +1,12 @@+This is the top-level directory for HaskellDirect, an IDL compiler
+for Haskell.
+
+For details of how to compile this distribution, please consult the
+INSTALL file. General package info in ANNOUNCE.
+
+Author:  
+         Sigbjorn Finne <sof@dcs.gla.ac.uk>
+
+Contributor:
+         Daan Leijen <daan@cs.uu.nl>
+
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ comlib/AutoPrim.hs view
@@ -0,0 +1,503 @@+{-# OPTIONS -#include "autoPrim.h" #-}
+-- Automatically generated by HaskellDirect (ihc.exe), version 0.20
+-- Created: 20:12 Pacific Standard Time, Tuesday 16 December, 2003
+-- Command line: -fno-qualified-names -fno-imports -fno-export-lists -fhs-to-c -fno-overload-variant -fout-pointers-are-not-refs -fsubtyped-interface-pointers -c AutoPrim.idl -o AutoPrim.hs
+
+module AutoPrim where
+
+
+
+import Com (checkHR, marshallIUnknown, IUnknown, mkIID, IID, LCID)
+import HDirect (Ptr, allocBytes, marshallBool, readref, readStablePtr,
+                marshallPtr, readPtr, unmarshallref, trivialFree, doThenFree, free,
+                sizeofInt32, readInt32, unmarshallString, freeString, sizeofInt16, 
+                readInt16, sizeofDouble, readDouble, sizeofFloat, readFloat, Octet,
+		readBool, sizeofChar, readChar, unmarshallBool,
+		freeref, sizeofWord8, readWord8, sizeofWord32, readWord32,
+		StablePtr, sizeofPtr, readPtr, writePtr, sizeofForeignPtr )
+import SafeArray ( SAFEARRAY, marshallSAFEARRAY, unmarshallSAFEARRAY, readSAFEARRAY, sizeofSAFEARRAY )
+import Pointer ( allocMemory )
+import IOExts (unsafePerformIO)
+import Int  (Int32, Int16)
+import Word (Word8, Word32)
+import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )
+import Foreign.Ptr
+
+
+data VARIANT_ = VARIANT_
+type VARIANT = Ptr VARIANT_
+sizeofBSTR = sizeofPtr
+
+iidIDispatch :: IID (IDispatch ())
+iidIDispatch  = mkIID "{00020400-0000-0000-C000-000000000046}"
+
+sizeofVARIANT    :: Word32
+sizeofVARIANT         = 16
+
+marshallVARIANT   :: VARIANT -> IO VARIANT
+marshallVARIANT m = return m
+
+unmarshallVARIANT :: Ptr a -> IO VARIANT
+unmarshallVARIANT v = return (castPtr v)
+
+readVARIANT       :: Ptr VARIANT -> IO VARIANT
+readVARIANT ptr = 
+  readPtr ptr
+--  unmarshallVARIANT ptr
+
+writeVARIANT      :: Ptr VARIANT -> VARIANT -> IO ()
+writeVARIANT ptr v = writePtr ptr v
+
+copyVARIANT      :: VARIANT -> VARIANT -> IO ()
+copyVARIANT ptr v = do
+  primCopyVARIANT (castPtr ptr) (castPtr v)
+  -- ToDo: if the passed in variant has a finaliser
+  -- attached to it, this is the time to disable those.
+  -- It doesn't at the moment, though.
+
+allocVARIANT :: IO VARIANT
+allocVARIANT = do
+  x <- allocMemory (fromIntegral sizeofVARIANT)
+  variantInit x
+  return x
+
+{- BEGIN_GHC_ONLY 
+foreign import ccall "writeVarInt" writeVarStablePtr
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+primitive writeVarStablePtr "prim_AutoPrim_writeVarInt"
+{- END_NOT_FOR_GHC -}
+     :: StablePtr a -> Ptr (StablePtr a) -> IO ()
+
+{- BEGIN_GHC_ONLY 
+foreign import ccall "readVarInt" prim_readVarStablePtr 
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+primitive prim_readVarStablePtr "prim_AutoPrim_readVarInt"
+{- END_NOT_FOR_GHC -}
+     :: Ptr (StablePtr a) -> Ptr b -> IO Int32
+
+readVarStablePtr :: VARIANT -> IO (StablePtr a)
+readVarStablePtr p = do
+    i <- allocBytes (fromIntegral sizeofInt32)
+    o_readVarInt <- prim_readVarStablePtr (castPtr p) i
+    checkHR o_readVarInt
+    doThenFree (freeref trivialFree) (unmarshallref readStablePtr) i
+
+
+type DISPID = Int32
+type PEXCEPINFO = Ptr ()
+-- --------------------------------------------------
+-- 
+-- interface IDispatch
+-- 
+-- --------------------------------------------------
+data IDispatch_ a = IDispatch__
+                      
+type IDispatch a = IUnknown (IDispatch_ a)
+dispatchInvoke :: IDispatch a0
+               -> DISPID
+               -> LCID
+               -> Bool
+               -> Word32
+               -> Word32
+               -> Word32
+               -> VARIANT
+               -> VARIANT
+               -> IO (PEXCEPINFO, Int32)
+dispatchInvoke obj dispid lcid isfunction flags cargs cargsout args argsout =
+  do
+    info <- allocBytes (fromIntegral sizeofPtr)
+    obj <- marshallIUnknown obj
+    isfunction <- marshallBool isfunction
+    o_dispatchInvoke <- withForeignPtr obj (\ obj -> prim_AutoPrim_dispatchInvoke obj dispid lcid isfunction flags cargs cargsout args argsout info)
+    info <- doThenFree free readPtr info
+    return (info, o_dispatchInvoke)
+
+foreign import ccall "dispatchInvoke" prim_AutoPrim_dispatchInvoke :: Ptr (IDispatch a) -> Int32 -> Word32 -> Int32 -> Word32 -> Word32 -> Word32 -> VARIANT -> VARIANT -> Ptr (Ptr ()) -> IO Int32
+dispatchGetMemberID :: IDispatch a0
+                    -> Ptr String
+                    -> LCID
+                    -> IO (DISPID, Int32)
+dispatchGetMemberID obj name lcid =
+  do
+    dispid <- allocBytes (fromIntegral sizeofInt32)
+    obj <- marshallIUnknown obj
+    o_dispatchGetMemberID <- withForeignPtr obj (\ obj -> prim_AutoPrim_dispatchGetMemberID obj name lcid dispid)
+    dispid <- doThenFree free readInt32 dispid
+    return (dispid, o_dispatchGetMemberID)
+
+foreign import ccall "dispatchGetMemberID" prim_AutoPrim_dispatchGetMemberID :: Ptr (IDispatch a) -> Ptr String -> Word32 -> Ptr Int32 -> IO Int32
+freeExcepInfo :: PEXCEPINFO
+              -> IO ()
+freeExcepInfo einfo =
+  prim_AutoPrim_freeExcepInfo einfo
+
+foreign import ccall "freeExcepInfo" prim_AutoPrim_freeExcepInfo :: Ptr () -> IO ()
+getExcepInfoMessage :: PEXCEPINFO
+                    -> IO (Ptr Char)
+getExcepInfoMessage info = prim_AutoPrim_getExcepInfoMessage info
+
+foreign import ccall "getExcepInfoMessage" prim_AutoPrim_getExcepInfoMessage :: Ptr () -> IO (Ptr Char)
+freeVariants :: Word32
+             -> VARIANT
+             -> IO ()
+freeVariants count p =
+  prim_AutoPrim_freeVariants count
+                             p
+
+foreign import ccall "freeVariants" prim_AutoPrim_freeVariants :: Word32 -> VARIANT -> IO ()
+readVariantTag :: VARIANT
+               -> IO Int32
+readVariantTag p = prim_AutoPrim_readVariantTag p
+
+foreign import ccall "readVariantTag" prim_AutoPrim_readVariantTag :: VARIANT -> IO Int32
+variantInit :: VARIANT
+            -> IO ()
+variantInit p =
+  prim_AutoPrim_variantInit p
+
+foreign import stdcall "VariantInit" prim_AutoPrim_variantInit :: VARIANT -> IO ()
+writeVarShort :: Int16
+              -> VARIANT
+              -> IO ()
+writeVarShort i p =
+  prim_AutoPrim_writeVarShort i
+                              p
+
+foreign import ccall "writeVarShort" prim_AutoPrim_writeVarShort :: Int16 -> VARIANT -> IO ()
+readVarShort :: VARIANT
+             -> IO Int16
+readVarShort p =
+  do
+    i <- allocBytes (fromIntegral sizeofInt16)
+    o_readVarShort <- prim_AutoPrim_readVarShort p i
+    checkHR o_readVarShort
+    doThenFree free readInt16 i
+
+foreign import ccall "readVarShort" prim_AutoPrim_readVarShort :: VARIANT -> Ptr Int16 -> IO Int32
+writeVarInt :: Int32
+            -> VARIANT
+            -> IO ()
+writeVarInt i p =
+  prim_AutoPrim_writeVarInt i
+                            p
+
+foreign import ccall "writeVarInt" prim_AutoPrim_writeVarInt :: Int32 -> VARIANT -> IO ()
+readVarInt :: VARIANT
+           -> IO Int32
+readVarInt p =
+  do
+    i <- allocBytes (fromIntegral sizeofInt32)
+    o_readVarInt <- prim_AutoPrim_readVarInt p i
+    checkHR o_readVarInt
+    doThenFree free readInt32 i
+
+foreign import ccall "readVarInt" prim_AutoPrim_readVarInt :: VARIANT -> Ptr Int32 -> IO Int32
+writeVarWord :: Word32
+             -> VARIANT
+             -> IO ()
+writeVarWord i p =
+  prim_AutoPrim_writeVarWord i
+                             p
+
+foreign import ccall "writeVarWord" prim_AutoPrim_writeVarWord :: Word32 -> VARIANT -> IO ()
+readVarWord :: VARIANT
+            -> IO Word32
+readVarWord p =
+  do
+    i <- allocBytes (fromIntegral sizeofWord32)
+    o_readVarWord <- prim_AutoPrim_readVarWord p i
+    checkHR o_readVarWord
+    doThenFree free readWord32 i
+
+foreign import ccall "readVarWord" prim_AutoPrim_readVarWord :: VARIANT -> Ptr Word32 -> IO Int32
+writeVarFloat :: Float
+              -> VARIANT
+              -> IO ()
+writeVarFloat i p =
+  prim_AutoPrim_writeVarFloat i
+                              p
+
+foreign import ccall "writeVarFloat" prim_AutoPrim_writeVarFloat :: Float -> VARIANT -> IO ()
+readVarFloat :: VARIANT
+             -> IO Float
+readVarFloat p =
+  do
+    i <- allocBytes (fromIntegral sizeofFloat)
+    o_readVarFloat <- prim_AutoPrim_readVarFloat p i
+    checkHR o_readVarFloat
+    doThenFree free readFloat i
+
+foreign import ccall "readVarFloat" prim_AutoPrim_readVarFloat :: VARIANT -> Ptr Float -> IO Int32
+writeVarDouble :: Double
+               -> VARIANT
+               -> IO ()
+writeVarDouble i p =
+  prim_AutoPrim_writeVarDouble i
+                               p
+
+foreign import ccall "writeVarDouble" prim_AutoPrim_writeVarDouble :: Double -> VARIANT -> IO ()
+readVarDouble :: VARIANT
+              -> IO Double
+readVarDouble p =
+  do
+    i <- allocBytes (fromIntegral sizeofDouble)
+    o_readVarDouble <- prim_AutoPrim_readVarDouble p i
+    checkHR o_readVarDouble
+    doThenFree free readDouble i
+
+foreign import ccall "readVarDouble" prim_AutoPrim_readVarDouble :: VARIANT -> Ptr Double -> IO Int32
+writeVarString :: Ptr Char
+               -> VARIANT
+               -> IO ()
+writeVarString str p =
+  prim_AutoPrim_writeVarString str
+                               p
+
+foreign import ccall "writeVarString" prim_AutoPrim_writeVarString :: Ptr Char -> VARIANT -> IO ()
+readVarString :: VARIANT
+              -> IO (Ptr (Ptr Char), Ptr VARIANT)
+readVarString p =
+  do
+    pstr <- allocBytes (fromIntegral sizeofPtr)
+    w <- allocBytes (fromIntegral sizeofVARIANT)
+    o_readVarString <- prim_AutoPrim_readVarString p pstr w
+    checkHR o_readVarString
+    return (pstr, w)
+
+foreign import ccall "readVarString" prim_AutoPrim_readVarString :: VARIANT -> Ptr (Ptr Char) -> Ptr VARIANT -> IO Int32
+writeVarDispatch :: IDispatch a0
+                 -> VARIANT
+                 -> IO ()
+writeVarDispatch ip p =
+  do
+    ip <- marshallIUnknown ip
+    withForeignPtr ip (\ ip -> prim_AutoPrim_writeVarDispatch ip p)
+
+foreign import ccall "writeVarDispatch" prim_AutoPrim_writeVarDispatch :: Ptr (IDispatch a) -> VARIANT -> IO ()
+readVarDispatch :: VARIANT
+                -> IO (Ptr (Ptr ()), Ptr VARIANT)
+readVarDispatch p =
+  do
+    ip <- allocBytes (fromIntegral sizeofPtr)
+    w <- allocBytes (fromIntegral sizeofVARIANT)
+    o_readVarDispatch <- prim_AutoPrim_readVarDispatch p ip w
+    checkHR o_readVarDispatch
+    return (ip, w)
+
+foreign import ccall "readVarDispatch" prim_AutoPrim_readVarDispatch :: VARIANT -> Ptr (Ptr ()) -> Ptr VARIANT -> IO Int32
+writeVarOptional :: VARIANT
+                 -> IO ()
+writeVarOptional p =
+  prim_AutoPrim_writeVarOptional p
+
+foreign import ccall "writeVarOptional" prim_AutoPrim_writeVarOptional :: VARIANT -> IO ()
+writeVarError :: Int32
+              -> VARIANT
+              -> IO ()
+writeVarError err p =
+  prim_AutoPrim_writeVarError err
+                              p
+
+foreign import ccall "writeVarError" prim_AutoPrim_writeVarError :: Int32 -> VARIANT -> IO ()
+readVarError :: VARIANT
+             -> IO Int32
+readVarError p =
+  do
+    perr <- allocBytes (fromIntegral sizeofInt32)
+    o_readVarError <- prim_AutoPrim_readVarError p perr
+    checkHR o_readVarError
+    doThenFree free readInt32 perr
+
+foreign import ccall "readVarError" prim_AutoPrim_readVarError :: VARIANT -> Ptr Int32 -> IO Int32
+writeVarBool :: Bool
+             -> VARIANT
+             -> IO ()
+writeVarBool b p =
+  do
+    b <- marshallBool b
+    prim_AutoPrim_writeVarBool b p
+
+foreign import ccall "writeVarBool" prim_AutoPrim_writeVarBool :: Int32 -> VARIANT -> IO ()
+readVarBool :: VARIANT
+            -> IO Bool
+readVarBool p =
+  do
+    pb <- allocBytes (fromIntegral sizeofInt32)
+    o_readVarBool <- prim_AutoPrim_readVarBool p pb
+    checkHR o_readVarBool
+    doThenFree free readBool pb
+
+foreign import ccall "readVarBool" prim_AutoPrim_readVarBool :: VARIANT -> Ptr Int32 -> IO Int32
+writeVarUnknown :: IUnknown a0
+                -> VARIANT
+                -> IO ()
+writeVarUnknown ip p =
+  do
+    ip <- marshallIUnknown ip
+    withForeignPtr ip (\ ip -> prim_AutoPrim_writeVarUnknown ip p)
+
+foreign import ccall "writeVarUnknown" prim_AutoPrim_writeVarUnknown :: Ptr (IUnknown a) -> VARIANT -> IO ()
+readVarUnknown :: VARIANT
+               -> IO (Ptr (Ptr ()), Ptr VARIANT)
+readVarUnknown p =
+  do
+    ip <- allocBytes (fromIntegral sizeofPtr)
+    w <- allocBytes (fromIntegral sizeofVARIANT)
+    o_readVarUnknown <- prim_AutoPrim_readVarUnknown p ip w
+    checkHR o_readVarUnknown
+    return (ip, w)
+
+foreign import ccall "readVarUnknown" prim_AutoPrim_readVarUnknown :: VARIANT -> Ptr (Ptr ()) -> Ptr VARIANT -> IO Int32
+writeVarByte :: Octet
+             -> VARIANT
+             -> IO ()
+writeVarByte b p =
+  prim_AutoPrim_writeVarByte b
+                             p
+
+foreign import ccall "writeVarByte" prim_AutoPrim_writeVarByte :: Word8 -> VARIANT -> IO ()
+readVarByte :: VARIANT
+            -> IO Octet
+readVarByte p =
+  do
+    pb <- allocBytes (fromIntegral sizeofWord8)
+    o_readVarByte <- prim_AutoPrim_readVarByte p pb
+    checkHR o_readVarByte
+    doThenFree free readWord8 pb
+
+foreign import ccall "readVarByte" prim_AutoPrim_readVarByte :: VARIANT -> Ptr Word8 -> IO Int32
+writeVarEmpty :: VARIANT
+              -> IO ()
+writeVarEmpty p =
+  prim_AutoPrim_writeVarEmpty p
+
+foreign import ccall "writeVarEmpty" prim_AutoPrim_writeVarEmpty :: VARIANT -> IO ()
+writeVarNull :: VARIANT
+             -> IO ()
+writeVarNull p =
+  prim_AutoPrim_writeVarNull p
+
+foreign import ccall "writeVarNull" prim_AutoPrim_writeVarNull :: VARIANT -> IO ()
+readVarNull :: VARIANT
+            -> IO ()
+readVarNull p =
+  do
+    o_readVarNull <- prim_AutoPrim_readVarNull p
+    checkHR o_readVarNull
+
+foreign import ccall "readVarNull" prim_AutoPrim_readVarNull :: VARIANT -> IO Int32
+writeVarCurrency :: Int32
+                 -> Word32
+                 -> VARIANT
+                 -> IO ()
+writeVarCurrency hi lo p =
+  prim_AutoPrim_writeVarCurrency hi
+                                 lo
+                                 p
+
+foreign import ccall "writeVarCurrency" prim_AutoPrim_writeVarCurrency :: Int32 -> Word32 -> VARIANT -> IO ()
+readVarCurrency :: VARIANT
+                -> IO (Int32, Int32)
+readVarCurrency p =
+  do
+    hi <- allocBytes (fromIntegral sizeofInt32)
+    lo <- allocBytes (fromIntegral sizeofInt32)
+    o_readVarCurrency <- prim_AutoPrim_readVarCurrency p hi lo
+    checkHR o_readVarCurrency
+    hi <- doThenFree free readInt32 hi
+    lo <- doThenFree free readInt32 lo
+    return (hi, lo)
+
+foreign import ccall "readVarCurrency" prim_AutoPrim_readVarCurrency :: VARIANT -> Ptr Int32 -> Ptr Int32 -> IO Int32
+writeVarWord64 :: Word32
+               -> Word32
+               -> VARIANT
+               -> IO ()
+writeVarWord64 hi lo p =
+  prim_AutoPrim_writeVarWord64 hi
+                               lo
+                               p
+
+foreign import ccall "writeVarWord64" prim_AutoPrim_writeVarWord64 :: Word32 -> Word32 -> VARIANT -> IO ()
+readVarWord64 :: VARIANT
+              -> IO (Word32, Word32)
+readVarWord64 p =
+  do
+    hi <- allocBytes (fromIntegral sizeofWord32)
+    lo <- allocBytes (fromIntegral sizeofWord32)
+    o_readVarWord64 <- prim_AutoPrim_readVarWord64 p hi lo
+    checkHR o_readVarWord64
+    hi <- doThenFree free readWord32 hi
+    lo <- doThenFree free readWord32 lo
+    return (hi, lo)
+
+foreign import ccall "readVarWord64" prim_AutoPrim_readVarWord64 :: VARIANT -> Ptr Word32 -> Ptr Word32 -> IO Int32
+writeVarVariant :: VARIANT
+                -> VARIANT
+                -> IO ()
+writeVarVariant p1 p2 =
+  prim_AutoPrim_writeVarVariant p1
+                                p2
+
+foreign import ccall "writeVarVariant" prim_AutoPrim_writeVarVariant :: VARIANT -> VARIANT -> IO ()
+readVarVariant :: VARIANT
+               -> IO (Ptr VARIANT)
+readVarVariant p1 =
+  do
+    p2 <- allocBytes (fromIntegral sizeofVARIANT)
+    o_readVarVariant <- prim_AutoPrim_readVarVariant p1 p2
+    checkHR o_readVarVariant
+    return (p2)
+
+foreign import ccall "readVarVariant" prim_AutoPrim_readVarVariant :: VARIANT -> Ptr VARIANT -> IO Int32
+writeVarSAFEARRAY :: VARIANT
+                  -> SAFEARRAY
+                  -> Int32
+                  -> IO ()
+writeVarSAFEARRAY p1 p2 vt =
+  do
+    p2 <- marshallSAFEARRAY p2
+    withForeignPtr p2 (\ p2 -> prim_AutoPrim_writeVarSAFEARRAY p1 p2 vt)
+
+foreign import ccall "writeVarSAFEARRAY" prim_AutoPrim_writeVarSAFEARRAY :: VARIANT -> Ptr SAFEARRAY -> Int32 -> IO ()
+readVarSAFEARRAY :: VARIANT
+                 -> Int32
+                 -> IO (Ptr ())
+readVarSAFEARRAY p1 vt =
+  do
+    p2 <- allocBytes (fromIntegral sizeofPtr)
+    o_readVarSAFEARRAY <- prim_AutoPrim_readVarSAFEARRAY p1 p2 vt
+    checkHR o_readVarSAFEARRAY
+    return (p2)
+
+foreign import ccall "readVarSAFEARRAY" prim_AutoPrim_readVarSAFEARRAY :: VARIANT -> Ptr () -> Int32 -> IO Int32
+primCopyVARIANT :: VARIANT
+                -> VARIANT
+                -> IO ()
+primCopyVARIANT p1 p2 =
+  do
+    o_primCopyVARIANT <- prim_AutoPrim_primCopyVARIANT p1 p2
+    checkHR o_primCopyVARIANT
+
+foreign import ccall "primCopyVARIANT" prim_AutoPrim_primCopyVARIANT :: VARIANT -> VARIANT -> IO Int32
+primVARIANTClear :: VARIANT
+                 -> IO ()
+primVARIANTClear p1 =
+  do
+    o_primVARIANTClear <- prim_AutoPrim_primVARIANTClear p1
+    checkHR o_primVARIANTClear
+
+foreign import ccall "primVARIANTClear" prim_AutoPrim_primVARIANTClear :: VARIANT -> IO Int32
+primClockToDate :: Int32
+                -> IO Double
+primClockToDate ct =
+  do
+    pT <- allocBytes (fromIntegral sizeofDouble)
+    o_primClockToDate <- prim_AutoPrim_primClockToDate ct pT
+    checkHR o_primClockToDate
+    doThenFree free readDouble pT
+
+foreign import ccall "primClockToDate" prim_AutoPrim_primClockToDate :: Int32 -> Ptr Double -> IO Int32
+
+ comlib/AutoPrim.idl view
@@ -0,0 +1,188 @@+
+/*
+ Primitive marshalling and invocation functions
+ needed by Haskell client Automation library.
+*/
+stub_include("autoPrim.h");
+module AutoPrim {
+
+import "SafeArray.idl";
+hs_quote("
+import Com (checkHR, marshallIUnknown, IUnknown, mkIID, IID, LCID)
+import HDirect (Ptr, allocBytes, marshallBool, readref, readStablePtr,
+                marshallPtr, readPtr, unmarshallref, trivialFree, doThenFree, free,
+                sizeofInt32, readInt32, unmarshallString, freeString, sizeofInt16, 
+                readInt16, sizeofDouble, readDouble, sizeofFloat, readFloat, Octet,
+		readBool, sizeofChar, readChar, unmarshallBool,
+		freeref, sizeofWord8, readWord8, sizeofWord32, readWord32,
+		StablePtr, sizeofPtr, readPtr, writePtr, sizeofForeignPtr )
+import SafeArray ( SAFEARRAY, marshallSAFEARRAY, unmarshallSAFEARRAY, readSAFEARRAY, sizeofSAFEARRAY )
+import Pointer ( allocMemory )
+import IOExts (unsafePerformIO)
+import Int  (Int32, Int16)
+import Word (Word8, Word32)
+import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )
+import Foreign.Ptr
+");
+
+hs_quote("
+data VARIANT_ = VARIANT_
+type VARIANT = Ptr VARIANT_
+sizeofBSTR = sizeofPtr
+
+iidIDispatch :: IID (IDispatch ())
+iidIDispatch  = mkIID \"{00020400-0000-0000-C000-000000000046}\"
+
+sizeofVARIANT    :: Word32
+sizeofVARIANT         = 16
+
+marshallVARIANT   :: VARIANT -> IO VARIANT
+marshallVARIANT m = return m
+
+unmarshallVARIANT :: Ptr a -> IO VARIANT
+unmarshallVARIANT v = return (castPtr v)
+
+readVARIANT       :: Ptr VARIANT -> IO VARIANT
+readVARIANT ptr = 
+  readPtr ptr
+--  unmarshallVARIANT ptr
+
+writeVARIANT      :: Ptr VARIANT -> VARIANT -> IO ()
+writeVARIANT ptr v = writePtr ptr v
+
+copyVARIANT      :: VARIANT -> VARIANT -> IO ()
+copyVARIANT ptr v = do
+  primCopyVARIANT (castPtr ptr) (castPtr v)
+  -- ToDo: if the passed in variant has a finaliser
+  -- attached to it, this is the time to disable those.
+  -- It doesn't at the moment, though.
+
+allocVARIANT :: IO VARIANT
+allocVARIANT = do
+  x <- allocMemory (fromIntegral sizeofVARIANT)
+  variantInit x
+  return x
+
+{- BEGIN_GHC_ONLY 
+foreign import ccall \"writeVarInt\" writeVarStablePtr
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+primitive writeVarStablePtr \"prim_AutoPrim_writeVarInt\"
+{- END_NOT_FOR_GHC -}
+     :: StablePtr a -> Ptr (StablePtr a) -> IO ()
+
+{- BEGIN_GHC_ONLY 
+foreign import ccall \"readVarInt\" prim_readVarStablePtr 
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+primitive prim_readVarStablePtr \"prim_AutoPrim_readVarInt\"
+{- END_NOT_FOR_GHC -}
+     :: Ptr (StablePtr a) -> Ptr b -> IO Int32
+
+readVarStablePtr :: VARIANT -> IO (StablePtr a)
+readVarStablePtr p = do
+    i <- allocBytes (fromIntegral sizeofInt32)
+    o_readVarInt <- prim_readVarStablePtr (castPtr p) i
+    checkHR o_readVarInt
+    doThenFree (freeref trivialFree) (unmarshallref readStablePtr) i
+
+");
+
+ typedef long DISPID;
+
+ typedef [ptr]void* PEXCEPINFO;
+
+ interface IDispatch : IUnknown {} ;
+ 
+ int //HRESULT
+ dispatchInvoke ( [in]IDispatch* obj
+ 	        , [in]DISPID dispid
+		, [in]LCID lcid
+		, [in]boolean isfunction
+		, [in]unsigned int flags
+		, [in]unsigned int cargs
+		, [in]unsigned int cargsout
+		, [in,ptr]VARIANT* args
+		, [in,ptr]VARIANT* argsout
+		, [out,ref]PEXCEPINFO* info
+		);
+
+ int //HRESULT 
+ dispatchGetMemberID ( [in,ref]IDispatch* obj
+ 		     , [in,ptr]BSTR* name
+		     , [in]LCID lcid
+		     , [out,ref]DISPID* dispid
+		     );
+ void  freeExcepInfo([in]PEXCEPINFO einfo);
+
+ [ptr]char* getExcepInfoMessage ([in]PEXCEPINFO info);
+
+ void freeVariants ([in]unsigned int count, [in,ptr]VARIANT* p);
+
+ int  readVariantTag([in,ptr]VARIANT* p);
+
+ void __stdcall VariantInit ([in,ptr]VARIANT* p);
+
+ // Family of functions for reading&writing values to a VARIANT.
+
+ void writeVarShort   ([in]short i, [in,ptr]VARIANT* p);
+ HRESULT readVarShort ([in,ptr]VARIANT* p, [out,ref]short* i);
+
+ void writeVarInt   ([in]int i, [in,ptr]VARIANT* p);
+ HRESULT readVarInt ([in,ptr]VARIANT* p, [out,ref]int* i);
+
+ void writeVarWord   ([in]unsigned int i, [in,ptr]VARIANT* p);
+ HRESULT readVarWord ([in,ptr]VARIANT* p, [out,ref]unsigned int* i);
+
+ void writeVarFloat   ([in]float i, [in,ptr]VARIANT* p);
+ HRESULT readVarFloat ([in,ptr]VARIANT* p, [out,ref]float* i);
+
+ void writeVarDouble   ([in]double i, [in,ptr]VARIANT* p);
+ HRESULT readVarDouble ([in,ptr]VARIANT* p, [out,ref]double* i);
+
+ typedef [ignore,ptr]VARIANT* PVARIANT;
+ typedef [ignore,ptr]char*    PCHAR;
+
+ void writeVarString   ([in,ptr]char* str, [in,ptr]VARIANT* p);
+ HRESULT readVarString ([in,ptr]VARIANT* p, [out,ptr]PCHAR* pstr, [out,ptr]PVARIANT* w);
+
+ void writeVarDispatch   ([in,ref]IDispatch ip, [in,ptr]VARIANT* p);
+ HRESULT readVarDispatch ([in,ptr]VARIANT* p, [out,ptr]void** ip, [out,ptr]PVARIANT* w);
+
+ void writeVarOptional ( [in,ptr]VARIANT* p);
+
+ void writeVarError   ([in]int err, [in,ptr]VARIANT* p);
+ HRESULT readVarError ([in,ptr]VARIANT* p, [out,ref]int* perr);
+
+ void writeVarBool   ([in]boolean b, [in,ptr]VARIANT* p);
+ HRESULT readVarBool ([in,ptr]VARIANT* p, [out,ref]boolean* pb);
+
+ void writeVarUnknown   ([in,ref]IUnknown ip, [in,ptr]VARIANT* p);
+ HRESULT readVarUnknown ([in,ptr]VARIANT* p, [out,ptr]void** ip, [out,ptr]PVARIANT* w);
+
+ void writeVarByte   ([in]byte b, [in,ptr]VARIANT* p);
+ HRESULT readVarByte ([in,ptr]VARIANT* p, [out,ref]byte* pb);
+
+ void writeVarEmpty   ([in,ptr]VARIANT* p);
+
+ void writeVarNull   ([in,ptr]VARIANT* p);
+ HRESULT readVarNull ([in,ptr]VARIANT* p);
+
+ // Also used for Int64.
+ void writeVarCurrency   ([in]int hi, [in]unsigned int lo, [in,ptr]VARIANT* p);
+ HRESULT readVarCurrency ([in,ptr]VARIANT* p, [out,ref]int* hi, [out,ref]int* lo);
+
+ void writeVarWord64   ([in]unsigned long hi, [in]unsigned long lo, [in,ptr]VARIANT* p);
+ HRESULT readVarWord64 ([in,ptr]VARIANT* p, [out,ref]unsigned long* hi, [out,ref]unsigned long* lo);
+
+ void writeVarVariant   ([in,ptr]VARIANT* p1, [in,ptr]VARIANT* p2);
+ HRESULT readVarVariant ([in,ptr]VARIANT* p1, [out,ptr]PVARIANT* p2);
+
+ void writeVarSAFEARRAY   ([in,ptr]VARIANT* p1, [in,ptr]SAFEARRAY* p2, [in]int vt);
+ HRESULT readVarSAFEARRAY ([in,ptr]VARIANT* p1, [out,ptr]void* p2, [in]int vt);
+
+ HRESULT primCopyVARIANT ([in,ptr]VARIANT* p1, [in,ptr]VARIANT* p2);
+ HRESULT primVARIANTClear ([in,ptr]VARIANT* p1 );
+
+ HRESULT primClockToDate([in]int ct,[out]double* pT);
+};
+ comlib/AutoPrimSrc.c view
@@ -0,0 +1,591 @@+/*-----------------------------------------------------------
+ (c) 1998,  Daan Leijen, leijen@@fwi.uva.nl
+     1999-, Sigbjorn Finne sof@galconn.com
+
+  Changes:
+    * made cygwin32 (&gcc) friendly.
+        -- sof 10/98
+-----------------------------------------------------------*/
+
+
+#if !defined(__CYGWIN32__) && !defined(__MINGW32__)
+#define CINTERFACE
+#define COBJMACROS
+#endif
+#include <windows.h>
+#include <stdio.h>
+
+#if defined(__CYGWIN32__) || defined(__MINGW32__)
+#include <w32api.h>
+#endif
+
+#ifdef __GNUC__
+#include "comPrim.h"
+#include "autoPrim.h"
+#include "PointerSrc.h"
+#include <stdlib.h>
+#include <string.h>
+
+/* No support for nameless unions..yet. */
+#if __W32API_MAJOR_VERSION == 1
+#define cyVal n1.n2.n3.cyVal
+#define bVal n1.n2.n3.bVal
+#define punkVal n1.n2.n3.punkVal
+#define boolVal n1.n2.n3.boolVal
+#define pdispVal n1.n2.n3.pdispVal
+#define bstrVal  n1.n2.n3.bstrVal
+#define date     n1.n2.n3.date
+#define dblVal   n1.n2.n3.dblVal
+#define fltVal   n1.n2.n3.fltVal
+#define lVal     n1.n2.n3.lVal
+#define ulVal    n1.n2.n3.ulVal
+#define iVal     n1.n2.n3.iVal
+#define parray   n1.n2.n3.parray
+#define pparray  n1.n2.n3.pparray
+#define decVal   n1.decVal
+#define vt       n1.n2.vt
+#endif
+#endif
+
+/*-----------------------------------------------------------
+-- Invoke
+-----------------------------------------------------------*/
+
+HRESULT dispatchInvoke( IDispatch* obj, DISPID dispid, LCID lcid,
+                        BOOL isfunction, unsigned flags,
+                        int cargs, int cargsout,
+                        VARIANT* args, VARIANT* argsout,
+                        EXCEPINFO** info )
+{
+   HRESULT      hr;
+   DISPPARAMS   dp;
+   EXCEPINFO    excepInfo;
+   UINT         argErr;
+   VARIANT      varRes;
+   VARIANT*     res;
+   DISPID       dispput;
+   int          i;
+
+
+   if (info) *info = NULL;
+
+   /* create VT_BYREF variants for out parameters */
+   for (i = 0; i < cargsout; i++)
+   {
+        VariantInit( args+i );
+        args[i].vt    = argsout[i].vt | VT_BYREF;
+#if !defined(__GNUC__) || __W32API_MAJOR_VERSION > 1
+        args[i].byref = &(argsout[i].byref);
+#else
+        args[i].n1.n2.n3.byref = &(argsout[i].n1.n2.n3.byref);
+#endif
+   }
+
+   if (!obj) return E_POINTER;
+
+   dp.cArgs  = cargs;
+   dp.rgvarg = args;
+
+   /* set special flags for property puts */
+   if (flags & DISPATCH_PROPERTYPUT)
+   {
+     dispput = DISPID_PROPERTYPUT;
+     dp.rgdispidNamedArgs = &dispput;
+     dp.cNamedArgs = 1;
+   }
+   else
+   {
+     dp.rgdispidNamedArgs = NULL;
+     dp.cNamedArgs = 0;
+   }
+
+   /* if this is surely a function, return the
+      result in the first element of argsout, and
+      decrement the number of arguments */
+   if (isfunction)
+   {
+      dp.cArgs--;
+      dp.rgvarg++;
+      res = argsout;
+   }
+   else
+   {
+      res = &varRes;
+      VariantInit(res);
+   }
+
+   hr = IDispatch_Invoke( obj, dispid, &IID_NULL, lcid, flags,
+                          &dp, res, &excepInfo, &argErr );
+
+   /* if guessed that this was not a function, but it returned
+      a result (in varRes) or it complained about the number
+      of arguments, than we again try to call it but now as a function. */
+
+   /* Turned this smart off, leaving it to HDirect (and the user) to
+      make the distinction between memberX and functionX.  -- sof
+      
+      No, let's not -- sometimes the type information isn't precise
+      enough about this (e.g., the type info for msi.dll's
+      Installer.OpenDatabase() suggests its a _method_, but it turns
+      out to be a _function_.
+   */
+   if (!isfunction && flags == DISPATCH_METHOD &&
+       (hr == DISP_E_BADPARAMCOUNT || 
+        hr == DISP_E_TYPEMISMATCH  ||
+	res->vt != VT_EMPTY) ) {
+       isfunction = TRUE;
+       dp.cArgs--;
+       dp.rgvarg++;
+       VariantClear(res);
+       res = argsout;
+
+       hr = IDispatch_Invoke( obj, dispid, &IID_NULL, lcid, flags,
+                          &dp, res, &excepInfo, &argErr );
+   }
+   if (!isfunction)
+        VariantClear( res );
+
+   /* free the input arguments */
+   for (i = cargsout; i < cargs; i++)
+        VariantClear( args+i );
+
+   /* check for exceptions */
+   if (hr == DISP_E_EXCEPTION && info)
+   {
+       *info = (EXCEPINFO*)primAllocMemory( sizeof(EXCEPINFO));
+       if (*info)
+       {
+          **info = excepInfo;
+          if ((*info)->pfnDeferredFillIn)
+              (*info)->pfnDeferredFillIn( *info );
+       }
+   }
+   return hr;
+}
+
+void freeExcepInfo( EXCEPINFO* info )
+{
+   if (!info) return;
+
+   if (info->bstrSource)        SysFreeString( info->bstrSource );
+   if (info->bstrDescription)   SysFreeString( info->bstrDescription );
+   if (info->bstrHelpFile)      SysFreeString( info->bstrHelpFile );
+}
+
+char* getExcepInfoMessage( EXCEPINFO* info )
+{
+#define    MAXMSG       255
+#define    MAXSTR       80
+
+    char member[MAXSTR+1] = "";
+    char source[MAXSTR+1] = "";
+    char wcode[MAXSTR+1]  = "";
+    char description[MAXMSG+1] = "Exception occurred";
+    char* msg;
+
+    msg = primAllocMemory( MAXMSG+1 );
+    if (!msg) return NULL;
+
+    if (info)
+    {
+      if (info->bstrSource)
+      {
+         char sourceReg[MAXSTR];
+
+         wcstombs( sourceReg, info->bstrSource, MAXSTR );
+         if (ERROR_SUCCESS !=
+                           RegQueryValueA( HKEY_CLASSES_ROOT, sourceReg, source, NULL ))
+             wcstombs( source, info->bstrSource, MAXSTR );
+      }
+
+      if (info->wCode)
+      {
+	 sprintf( wcode, "(%d)", info->wCode );
+      }
+      
+      if (info->bstrDescription)
+      {   
+         wcstombs( description, info->bstrDescription, MAXMSG);
+      }
+      else if (info->scode)
+      {
+         strncpy( description, hresultString(info->scode), MAXMSG );
+      }
+   }
+
+   if (info && info->bstrSource)
+#ifdef __GNUC__
+      sprintf(msg, "%s.%s:%s %s", source, member, wcode, description);
+#else
+      _snprintf( msg, MAXMSG, "%s.%s:%s %s",
+                            source,member,wcode,description);
+#endif
+   else
+#ifdef __GNUC__
+      sprintf(msg, "%s %s", wcode, description);
+#else
+      _snprintf( msg, MAXMSG, "%s %s", wcode,description);
+#endif
+ 
+   return msg;
+}
+
+HRESULT dispatchGetMemberID( IDispatch* obj,
+                             BSTR name, LCID lcid, DISPID* dispid )
+{
+   if (obj) return IDispatch_GetIDsOfNames( obj, &IID_NULL,
+                                             &name, 1, lcid, dispid );
+       else return E_POINTER;
+}
+
+
+/*-----------------------------------------------------------
+-- Variant marshalling (we just lack VT_ARRAY support)
+-----------------------------------------------------------*/
+
+void freeVariants( int count, VARIANT* p )
+{
+   int i;
+   if (!p) return;
+   for (i = 0; i < count; i++)
+      VariantClear(p+i);
+}
+
+int readVariantTag(VARIANT* pw) { return(pw->vt); }
+
+#define READWRITEVAR(htp,ctp,tp,fld,def) \
+                                void writeVar##htp( ctp x, VARIANT* v )   \
+                                {                                       \
+                                   WRITEVAR(tp,fld);                     \
+                                }  \
+                                HRESULT readVar##htp( VARIANT* v, ctp* p ) \
+                                { \
+                                   READVAR(tp,fld,def); \
+                                }
+
+#define WRITEVAR(tp,fld)     {  if (!v) return; \
+                                VariantInit(v); \
+                                v->vt = tp; \
+                                v->fld = x; \
+                             }
+
+#define READVAR(tp,fld,def)  {  if (!p) return E_POINTER; \
+                                if (!v) { *p = def; return E_POINTER;} \
+                                if (v->vt == tp) {      \
+                                  *p = v->fld;          \
+                                  return S_OK;          \
+                                } else {                \
+                                  VARIANT w;            \
+                                  HRESULT hr;           \
+                                  VariantInit( &w );    \
+                                  hr = VariantChangeType( &w, v, 0, tp ); \
+                                  if (SUCCEEDED(hr)) *p = w.fld; \
+                                                else *p = def;   \
+                                  return hr;            \
+                              }                         \
+                            }
+
+
+#define READWRITETEMPVAR(htp,ctp,tp,fld,def) \
+                                void writeVar##htp( ctp x, VARIANT* v )   \
+                                {                                       \
+                                   WRITEVAR(tp,fld);                     \
+                                }  \
+                                HRESULT readVar##htp( VARIANT* v, ctp* p, VARIANT** w ) \
+                                { \
+                                   READTEMPVAR(tp,fld,def); \
+                                }
+
+
+#define READTEMPVAR(tp,fld,def) { if (w) *w = NULL;     \
+                                if (!p) return E_POINTER; \
+                                if (!v) { *p = def; return E_POINTER; } \
+                                if (v->vt == tp) {      \
+                                  *p = v->fld;          \
+                                  return S_OK;          \
+                                } else {                \
+                                  HRESULT hr;           \
+                                  *p = def;             \
+                                  if (!w) return E_POINTER; \
+                                  *w = primAllocMemory( sizeof(VARIANT)); \
+                                  if (*w == NULL) return E_OUTOFMEMORY;  \
+                                  VariantInit( *w );    \
+                                  hr = VariantChangeType( *w, v, 0, tp ); \
+                                  if (SUCCEEDED(hr)) *p = (*w)->fld; \
+                                                else { primFreeMemory(*w); *w = NULL; } \
+                                  return hr;            \
+                              }                         \
+                            }
+
+
+READWRITEVAR( Short, int, VT_I2, iVal, 0 )
+READWRITEVAR( Int, int, VT_I4, lVal, 0 )
+READWRITEVAR( Word, unsigned int, VT_UI4, ulVal, 0 )
+READWRITEVAR( Float, float, VT_R4, fltVal, 0.0 )
+READWRITEVAR( Double, double, VT_R8, dblVal, 0.0 )
+READWRITEVAR( Date, double, VT_DATE, date, 0.0 )
+READWRITETEMPVAR( String, BSTR, VT_BSTR, bstrVal, NULL )
+READWRITETEMPVAR( Dispatch, IDispatch*, VT_DISPATCH, pdispVal, NULL )
+READWRITEVAR( Bool, BOOL, VT_BOOL, boolVal, 0 )
+READWRITETEMPVAR( Unknown, IUnknown*, VT_UNKNOWN, punkVal, NULL )
+READWRITEVAR( Byte, unsigned char, VT_UI1, bVal, 0 )
+#if __W32API_MAJOR_VERSION == 1
+READWRITEVAR( Error, int, VT_ERROR, n1.n2.n3.scode, 0 )
+#else
+READWRITEVAR( Error, int, VT_ERROR, scode, 0 )
+#endif
+
+void
+writeVarOptional( VARIANT * v )
+{
+  if (!v) return;
+  VariantInit ( v );
+  v->vt       = VT_ERROR;
+#if __W32API_MAJOR_VERSION == 1
+  v->n1.n2.n3.scode = DISP_E_PARAMNOTFOUND;
+#else
+  v->scode = DISP_E_PARAMNOTFOUND;
+#endif
+
+}
+
+/* ToDo: readVarOptional */
+
+void 
+writeVarSAFEARRAY( VARIANT* v, SAFEARRAY* sa, VARTYPE ovt )
+{
+  if (!v) return;
+  VariantInit(v);
+  v->vt     = VT_ARRAY | ovt;
+  v->parray = sa;
+}
+
+HRESULT
+readVarSAFEARRAY( VARIANT* v, SAFEARRAY** sa, VARTYPE ovt)
+{
+  if (!v) return E_POINTER;
+  if (v->vt & VT_ARRAY || v->vt == VT_SAFEARRAY) {
+    /* Will return same pointer, but let's follow the rules. */
+    if (v->vt & VT_BYREF) {
+      *sa = *(v->pparray);
+    } else {
+      *sa = v->parray;
+    }
+    return S_OK;
+  } else {
+        VARIANT w;
+        HRESULT hr;
+
+        VariantInit(&w);
+        hr = VariantChangeType( &w, v, 0, VT_ARRAY | ovt);
+        if (SUCCEEDED(hr)) {
+           *sa = w.parray;
+        } else  {
+	   *sa = NULL;
+        }
+        return hr;
+  }
+}
+
+/* VT_EMPTY, VT_NULL, VT_CY, VT_VARIANT */
+
+void writeVarEmpty( VARIANT* v )
+{
+   if (!v) return;
+   VariantInit( v );
+   v->vt = VT_EMPTY;
+}
+
+/* readEmpty; succeeds always */
+
+void writeVarNull( VARIANT* v )
+{
+   if (!v) return;
+   VariantInit( v );
+   v->vt = VT_NULL;
+}
+
+HRESULT readVarNull( VARIANT* v )
+{
+  if (!v) return E_POINTER;
+  if (v->vt == VT_NULL)
+        return S_OK;
+  else
+  {
+        VARIANT w;
+        VariantInit( &w );
+        return VariantChangeType( &w, v, 0, VT_NULL );
+  }
+}
+
+void writeVarCurrency( int hi, unsigned int lo, VARIANT* v )
+{
+   if (!v) return;
+   VariantInit(v);
+   v->vt = VT_CY;
+   v->cyVal.Hi  = hi;
+   v->cyVal.Lo  = lo;
+}
+
+HRESULT readVarCurrency( VARIANT* v, int* hi, int* lo )
+{
+   if (!v) return E_POINTER;
+   if (!hi) return E_POINTER;
+   if (!lo) return E_POINTER;
+
+   if (v->vt == VT_CY)
+   {
+        *hi = v->cyVal.Hi;
+        *lo = v->cyVal.Lo;
+        return S_OK;
+   }
+   else
+   {
+        VARIANT w;
+        HRESULT hr;
+
+        VariantInit(&w);
+        hr = VariantChangeType( &w, v, 0, VT_CY);
+        if (SUCCEEDED(hr))
+        {
+                *hi = w.cyVal.Hi;
+                *lo = w.cyVal.Lo;
+        }
+        else
+        {
+                *hi = *lo = 0;
+        }
+        return hr;
+   }
+}
+
+void writeVarWord64( unsigned int hi, unsigned int lo, VARIANT* v )
+{
+   ULONGLONG r;
+
+   r = (ULONGLONG)hi;
+   r >>= 32;
+   r += (ULONGLONG)lo;
+
+   if (!v) return;
+   VariantInit(v);
+   v->vt = VT_DECIMAL;
+   v->decVal.Lo64  = r;
+   v->decVal.Hi32  = 0;
+   v->decVal.sign  = 0;
+   v->decVal.scale = 0;
+}
+
+HRESULT readVarWord64( VARIANT* v, unsigned int* hi, unsigned int* lo )
+{
+   ULONGLONG r;
+
+   if (!v) return E_POINTER;
+   if (!hi) return E_POINTER;
+   if (!lo) return E_POINTER;
+
+   if (v->vt == VT_DECIMAL)
+   {
+        r   = v->decVal.Lo64;
+	*lo = (unsigned long)r;
+	r   <<= 32;
+	*hi = (unsigned long)r;
+        return S_OK;
+   }
+   else
+   {
+        VARIANT w;
+        HRESULT hr;
+
+        VariantInit(&w);
+        hr = VariantChangeType( &w, v, 0, VT_DECIMAL);
+        if (SUCCEEDED(hr))
+        {
+	        r   = v->decVal.Lo64;
+	        *lo = (unsigned long)r;
+	        r   <<= 32;
+	        *hi = (unsigned long)r;
+        }
+        else
+        {
+                *hi = *lo = 0;
+        }
+        return hr;
+   }
+}
+
+
+void writeVarVariant( VARIANT* x, VARIANT* v)
+{
+   if (!v) return;
+   if (!x) return;
+
+   VariantInit(v);
+   VariantCopy( v, x );
+}
+
+HRESULT readVarVariant( VARIANT* v, VARIANT* x )
+{
+   if (!v)  return E_POINTER;
+   if (!x)  return E_POINTER;
+
+   VariantInit(x);
+   return VariantCopy( x, v );
+}
+
+/* 
+   First VARIANT* is uninitialised chunk of memory.
+   Initialise and copy the second one into it.
+*/
+HRESULT
+primCopyVARIANT ( VARIANT* p1
+                , VARIANT* p2
+		)
+{
+  VariantInit(p1);
+  return (VariantCopy(p1,p2));
+}
+
+HRESULT
+primVARIANTClear ( VARIANT* p1 )
+{
+  return VariantClear(p1);
+}
+
+/*
+ * Converting a time_t to date/time representation used by
+ * Automation.
+ */
+HRESULT
+primClockToDate (int t, double *pt) 
+{
+  FILETIME ft;
+  SYSTEMTIME st;
+  LONGLONG l = Int32x32To64(t, 10000000) + 116444736000000000;
+
+  ft.dwLowDateTime = (DWORD) l;
+  ft.dwHighDateTime = l >>32;
+  
+  if (!FileTimeToSystemTime(&ft,&st)) {
+    return E_FAIL;
+  }
+  
+#if ( (!defined(__MINGW32__) && !defined(__CYGWIN__)) || \
+       (__W32API_MAJOR_VERSION >= 1 && \
+         (__W32API_MAJOR_VERSION > 1 || __W32API_MINOR_VERSION >= 1)) )
+  /* If on a non-gnuwin platform or on one with a w32api version
+     that's 1.1 or greater.
+  */
+  if (!SystemTimeToVariantTime(&st, pt)) {
+    return E_FAIL;
+  }
+  return S_OK;
+#else
+  /* SystemTimeToVariantTime() isn't provided in the oleaut32
+     import library until w32api 1.1 (or thereabouts, haven't 
+     exactly pinpointed when this bug fixed).
+   */
+  return E_FAIL;
+#endif
+  
+}
+ comlib/Automation.lhs view
@@ -0,0 +1,2046 @@+%
+% Copyright (c) 1998-99,  Daan Leijen,    leijen@@fwi.uva.nl
+%                         Sigbjorn Finne  sof@@dcs.gla.ac.uk
+%
+
+\begin{code}
+{-# OPTIONS -#include "autoPrim.h" #-}
+module Automation (
+      module Com,
+
+      IDispatch_, IDispatch, iidIDispatch, 
+
+      queryIUnknown, queryIDispatch,
+
+      createObject, getObject, getActiveObject, getFileObject,
+
+      Member, DISPID, getMemberID, VARIANT, sizeofVARIANT,
+      marshallVARIANT, unmarshallVARIANT, readVARIANT, writeVARIANT,
+      copyVARIANT, allocVARIANT,
+
+      VarIn, VarRes, ArgIn, ArgInOut, ArgOut, ArgRes,
+
+      Variant(..),
+
+      defaultVariant, inVariant, resVariant, inoutVariant, outVariant,
+      defaultEmpty, inEmpty, resEmpty, inoutEmpty, outEmpty, inNoArg,
+      defaultInt, inInt, resInt, inoutInt, outInt,
+      defaultInt8, inInt8, resInt8, inoutInt8, outInt8,
+      defaultInt16, inInt16, resInt16, inoutInt16, outInt16,
+      defaultInt32, inInt32, resInt32, inoutInt32, outInt32,
+      defaultInt64, inInt64, resInt64, inoutInt64, outInt64,
+      defaultInteger, inInteger, resInteger, inoutInteger, outInteger,
+      defaultHRESULT, inHRESULT, resHRESULT, inoutHRESULT, outHRESULT,
+      defaultWord, inWord, resWord, inoutWord, outWord,
+      defaultWord8, inWord8, resWord8, inoutWord8, outWord8,
+      defaultWord16, inWord16, resWord16, inoutWord16, outWord16,
+      defaultWord32, inWord32, resWord32, inoutWord32, outWord32,
+      defaultWord64, inWord64, resWord64, inoutWord64, outWord64,
+      defaultBool, inBool, resBool, inoutBool, outBool,
+      defaultByte, inByte, resByte, inoutByte, outByte,
+      defaultChar, inChar, resChar, inoutChar, outChar,
+      defaultFloat, inFloat, resFloat, inoutFloat, outFloat,
+      defaultDouble, inDouble, resDouble, inoutDouble, outDouble,
+      defaultString, inString, resString, inoutString, outString,
+      defaultIUnknown, inIUnknown, resIUnknown, inoutIUnknown, outIUnknown,
+      defaultIDispatch, inIDispatch, resIDispatch, inoutIDispatch, outIDispatch,
+      defaultDate, inDate, resDate, inoutDate, outDate, Date,
+      defaultError, inError, resError, inoutError, outError,
+      defaultMaybe, inMaybe, resMaybe, inoutMaybe, outMaybe, inOptional,
+      defaultCurrency, inCurrency, resCurrency, inoutCurrency, outCurrency, Currency,
+      defaultSafeArray, inSafeArray, resSafeArray, inoutSafeArray, outSafeArray, SafeArray, mkSafeArray,
+      defaultEnum, inEnum, resEnum, inoutEnum, outEnum, vtTypeEnum,
+      inHaskellValue, unsafeResHaskellValue, unsafeOutHaskellValue,
+      defaultSqlNull, inSqlNull, resSqlNull, inoutSqlNull, outSqlNull,
+      SqlNull(..),
+     
+      inGUID, outGUID,
+
+      inDefaultValue, noInArg, 
+
+      propertyGet, propertySet, propertySetGet,
+      propertyGet2, propertyGet3, propertyGet4,
+      propertyGetID, propertySetID, propertySetGetID,
+      propertyGet2ID, propertyGet3ID, propertyGet4ID,
+
+      function1, function2, function3, function4, function5, function6, 
+      functionID1, functionID2, functionID3, functionID4, functionID5, functionID6,
+
+      method0, method1, method2, method3, method4, method5, method6, method7, method8,
+      methodID0, methodID1, methodID2, methodID3, methodID4,
+      methodID5, methodID6, methodID7, methodID8,
+
+      unmarshallVariants0, unmarshallVariants1,
+      unmarshallVariants2, unmarshallVariants3,
+      unmarshallVariants4, unmarshallVariants5,
+      unmarshallVariants6, unmarshallVariants7,
+      unmarshallVariants8,
+
+      readVariants0, readVariants1,
+      readVariants2, readVariants3,
+      readVariants4, readVariants5,
+      readVariants6, readVariants7,
+      readVariants8,
+
+      method_0_0, method_1_0, method_2_0, method_3_0, method_4_0,
+      method_0_1, method_1_1, method_2_1, method_3_1, method_4_1,
+      method_0_2, method_1_2, method_2_2, method_3_2, method_4_2,
+
+      function_0_1, function_1_1, function_2_1, function_3_1, function_4_1,
+      function_0_2, function_1_2, function_2_2, function_3_2, function_4_2,
+
+      propertyGet_0, propertyGet_1, propertyGet_2, propertyGet_3, propertyGet_4,
+      propertySet_1, propertySet_2, propertySet_3, propertySet_4,
+
+      invokePropertyGet, invokePropertySet,
+      invokeMethod, invokeFunction,
+
+      enumVariants,
+      
+{- BEGIN_GHC_ONLY
+      marshallCurrency, unmarshallCurrency,
+      readCurrency, writeCurrency,
+   END_GHC_ONLY -}
+      sizeofCurrency,
+      
+      VARENUM(..),
+      marshallVARENUM, unmarshallVARENUM,
+      readVARENUM, writeVARENUM,
+      sizeofVARENUM, 
+      
+      sizeofVARIANT_BOOL,
+      marshallVARIANT_BOOL, unmarshallVARIANT_BOOL,
+      readVARIANT_BOOL, writeVARIANT_BOOL,
+      vARIANT_TRUE, vARIANT_FALSE,
+      
+      marshallVariant, unmarshallVariant,
+      readVariant, writeVariant,
+      
+      readVarEnum, 
+      readVarInt, 
+      readVarFloat,
+      readVarDouble,
+      readVarString,
+      readVarBool
+
+      , marshallSafeArray
+      , unmarshallSafeArray
+      , writeSafeArray
+      , readSafeArray
+      , freeSafeArray
+      , readSA
+      
+      , clockTimeToDate    -- :: Time.ClockTime  -> IO Date
+    ) where
+
+import HDirect
+import IO   ( ioeGetErrorString )
+import Char ( chr, ord )
+import System.Time ( ClockTime(..) )
+
+import Word ( Word8, Word16, Word32 )
+import Int  ( Int32, Int16, Int8, Int64 )
+import Foreign.StablePtr
+
+import Com
+import ComPrim  ( stringToBSTR )
+import ComException ( dISP_E_UNKNOWNNAME, dISP_E_EXCEPTION )
+import AutoPrim
+import SafeArray ( addrToSAFEARRAY, marshallSAFEARRAY, readSAFEARRAY
+		 , writeSAFEARRAY, unmarshallSAFEARRAY, SAFEARRAY
+		 )
+import WideString
+import Pointer ( writeSeqAtDec, stackFrame, allocMemory, freeMemory )
+import ComException ( e_FAIL )
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import IOExts	    ( unsafePerformIO )
+import Bits
+
+\end{code}
+
+The following creation functions are the VB equivalents in Haskell,
+notice the `unsafe' interface pointer return types used here. The
+interface pointers returned are compatible with the stubs for
+*any* IDispatch-derived interface. This makes it more convenient
+(saves the extra QI / type cast), but means that it is now
+possible to get run-time errors of the sort:
+'method X called but not supported'.
+
+\begin{code}
+createObject  :: ProgID -> IO (IDispatch a)
+createObject progid
+      = coCreateObject progid iidIDispatch_unsafe
+
+iidIDispatch_unsafe  = mkIID "{00020400-0000-0000-C000-000000000046}"
+
+getFileObject :: String -> ProgID -> IO (IDispatch a)
+getFileObject fname progid = coGetFileObject fname progid iidIDispatch_unsafe
+
+getActiveObject :: ProgID -> IO (IDispatch a)
+getActiveObject progid
+      = coGetActiveObject progid iidIDispatch_unsafe
+
+getObject :: String -> IO (IDispatch a)
+getObject fname = coGetObject fname iidIDispatch_unsafe
+\end{code}
+
+The following functions are overloaded versions of the basic functions.
+The postfix "_n_m" means n input arguments and m results.
+
+\begin{code}
+method_0_0 name               = method0 name []
+method_1_0 name a1            = method0 name [inVariant a1] 
+method_2_0 name a1 a2         = method0 name [inVariant a1, inVariant a2]
+method_3_0 name a1 a2 a3      = method0 name [inVariant a1, inVariant a2, inVariant a3]
+method_4_0 name a1 a2 a3 a4   = method0 name [inVariant a1, inVariant a2, 
+                                              inVariant a3, inVariant a4]
+
+method_0_1 name               = method1 name [] outVariant
+method_1_1 name a1            = method1 name [inVariant a1] outVariant
+method_2_1 name a1 a2         = method1 name [inVariant a1, inVariant a2] outVariant
+method_3_1 name a1 a2 a3      = method1 name [inVariant a1, inVariant a2, 
+                                              inVariant a3] outVariant
+method_4_1 name a1 a2 a3 a4   = method1 name [inVariant a1, inVariant a2, 
+                                              inVariant a3, inVariant a4] outVariant
+
+method_0_2 name               = method2 name [] outVariant outVariant
+method_1_2 name a1            = method2 name [inVariant a1] outVariant outVariant
+method_2_2 name a1 a2         = method2 name [inVariant a1, inVariant a2] outVariant outVariant
+method_3_2 name a1 a2 a3      = method2 name [inVariant a1, inVariant a2, 
+                                              inVariant a3] outVariant outVariant
+method_4_2 name a1 a2 a3 a4   = method2 name [inVariant a1, inVariant a2, 
+                                              inVariant a3, inVariant a4] outVariant outVariant
+
+function_0_1 name               = function1 name [] outVariant
+function_1_1 name a1            = function1 name [inVariant a1] outVariant
+function_2_1 name a1 a2         = function1 name [inVariant a1, inVariant a2] outVariant
+function_3_1 name a1 a2 a3      = function1 name [inVariant a1, inVariant a2, 
+                                              inVariant a3] outVariant
+function_4_1 name a1 a2 a3 a4   = function1 name [inVariant a1, inVariant a2, 
+                                              inVariant a3, inVariant a4] outVariant
+
+function_0_2 name               = function2 name [] outVariant outVariant
+function_1_2 name a1            = function2 name [inVariant a1] outVariant outVariant
+function_2_2 name a1 a2         = function2 name [inVariant a1, inVariant a2] 
+                                                  outVariant outVariant
+function_3_2 name a1 a2 a3      = function2 name [inVariant a1, inVariant a2, 
+                                                  inVariant a3] outVariant outVariant
+function_4_2 name a1 a2 a3 a4   = function2 name [inVariant a1, inVariant a2, 
+                                                  inVariant a3, inVariant a4] 
+                                                  outVariant outVariant
+
+propertyGet_0 name              = propertyGet name [] outVariant
+propertyGet_1 name a1           = propertyGet name [inVariant a1] outVariant
+propertyGet_2 name a1 a2        = propertyGet name [inVariant a1, inVariant a2] outVariant
+propertyGet_3 name a1 a2 a3     = propertyGet name [inVariant a1, inVariant a2,
+                                                    inVariant a3] outVariant
+propertyGet_4 name a1 a2 a3 a4  = propertyGet name [inVariant a1, inVariant a2,
+                                                    inVariant a3, inVariant a4] outVariant
+
+propertySet_1 name a1           = propertySet name [inVariant a1]
+propertySet_2 name a1 a2        = propertySet name [inVariant a1, inVariant a2]
+propertySet_3 name a1 a2 a3     = propertySet name [inVariant a1, inVariant a2, inVariant a3]
+propertySet_4 name a1 a2 a3 a4  = propertySet name [inVariant a1, inVariant a2,
+                                                    inVariant a3, inVariant a4]
+\end{code}
+
+Automation member functions or properties are identified
+by name or DISPID.
+
+\begin{code}
+type Member        = String
+--type DISPID        = Int
+sizeDISPID         = 4
+
+getMemberID :: Member -> IDispatch a -> IO DISPID
+getMemberID name obj = do 
+   bstr        <- allocBSTR name
+   (dispid,hr) <- dispatchGetMemberID (castIface obj) bstr lcidNeutral
+                       `always` freeBSTR bstr
+   checkHR hr  `catch` (handleErr hr)
+   return dispid
+ where
+  handleErr hr err
+    | hr == dISP_E_UNKNOWNNAME =
+       coFail ("method '" ++ name ++ "' called but not supported by object")
+    | otherwise		      = errorMember name err
+
+\end{code}
+
+Type definitions for marshalling functions. Variants are represented
+as functions that can read or write a value from or to a variant structure.
+
+\begin{code}
+type VarIn            = VARIANT -> IO ()
+type VarRes a         = VARIANT -> IO a
+
+type ArgIn a          = a -> VarIn
+type ArgRes a         = VarRes a
+type ArgOut a         = (VarIn,ArgRes a)
+type ArgInOut a b     = a -> ArgOut b
+\end{code}
+
+For each type we define 5 functions; @defaultT@, @inT@,
+@resT@, @inoutT@, @outT@ where the last
+two functions are defined in terms of the first three.
+The @Variant@ class overloads these functions; if an
+argument can be more than one type, it will be overloaded
+and Haskell takes care of resolving the marshall function to use.
+We enable overlapping instance by providing explicit constructor functions
+in the class definition.
+
+Input variants.
+
+\begin{code}
+class Variant a where
+  inVariant :: ArgIn a
+  inVarList :: ArgIn [a]
+  inVarIUnknown :: ArgIn (IUnknown a)
+
+  vtEltType :: a -> VARENUM
+
+  resVariant :: ArgRes a
+  defaultVariant :: a
+
+  resVarList :: ArgRes [a]
+  resVarIUnknown :: ArgRes (IUnknown a)
+  resVarIDispatch :: ArgRes (IDispatch a)
+\end{code}
+
+Overlapping instance for strings.
+
+\begin{code}
+instance Variant a => Variant [a] where
+  inVariant       = inVarList
+  resVariant      = resVarList
+  defaultVariant  = []
+
+
+instance Variant Char where
+  inVariant   = inChar
+  resVariant  = resChar
+  inVarList   = inString
+  resVarList  = resString
+  
+  vtEltType _ = VT_UI1
+\end{code}
+
+Overlapping instance for @IDispatch a@ and @IUnknown ()@
+variants.
+
+\begin{code}
+instance Variant a => Variant (IUnknown_ a) where
+  inVariant   = inVarIUnknown
+  resVariant  = resVarIUnknown
+  defaultVariant = defaultIUnknown
+
+  vtEltType _ = VT_UNKNOWN
+
+instance Variant (IDispatch_ a) where
+  inVarIUnknown  = inIDispatch
+  resVarIUnknown = resIDispatch
+
+  vtEltType _ = VT_DISPATCH
+
+instance Variant () where
+  inVarIUnknown   = inIUnknown
+  resVarIUnknown  = resIUnknown
+  resVarIDispatch = resIDispatch
+
+  inVariant      = inNoArg
+  resVariant     = resEmpty
+  defaultVariant = defaultEmpty
+
+  vtEltType _ = VT_ERROR
+\end{code}
+
+Normal instances.
+
+\begin{code}
+instance Variant Bool where
+  inVariant   = inBool
+  resVariant  = resBool
+  defaultVariant = defaultBool
+
+  vtEltType _ = VT_UI4
+
+instance Variant Int where
+  inVariant   = inInt
+  resVariant  = resInt
+  defaultVariant = defaultInt
+
+  vtEltType _ = VT_I4
+
+instance Variant Int32 where
+  inVariant   = inHRESULT
+  resVariant  = resHRESULT
+  defaultVariant = defaultHRESULT
+
+  vtEltType _ = VT_I4
+
+instance Variant Int16 where
+  inVariant   = inInt16
+  resVariant  = resInt16
+  defaultVariant = defaultInt16
+
+  vtEltType _ = VT_I2
+
+instance Variant Int8 where
+  inVariant   = inInt8
+  resVariant  = resInt8
+  defaultVariant = defaultInt8
+
+  vtEltType _ = VT_I1
+
+{- BEGIN_GHC_ONLY
+instance Variant Int64 where
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+instance Variant Integer where
+{- END_NOT_FOR_GHC -}
+  inVariant   = inInt64
+  resVariant  = resInt64
+  defaultVariant = defaultInt64
+
+  vtEltType _ = VT_CY -- since VT_I8 isn't supported in VARIANTs.
+
+instance Variant Word8 where
+  inVariant   = inWord8
+  resVariant  = resWord8
+  defaultVariant = defaultWord8
+
+  vtEltType _ = VT_UI1
+
+instance Variant Word16 where
+  inVariant   = inWord16
+  resVariant  = resWord16
+  defaultVariant = defaultWord16
+
+  vtEltType _ = VT_UI2
+
+instance Variant Word32 where
+  inVariant   = inWord32
+  resVariant  = resWord32
+  defaultVariant = defaultWord32
+
+  vtEltType _ = VT_UI4
+
+{- BEGIN_GHC_ONLY
+instance Variant Word64 where
+  inVariant   = inWord64
+  resVariant  = resWord64
+  defaultVariant = defaultWord64
+
+  vtEltType _ = VT_DECIMAL  -- since VT_UI8 isn't supported in VARIANTs.
+   END_GHC_ONLY -}
+
+instance Variant Float where
+  inVariant   = inFloat
+  resVariant  = resFloat
+  defaultVariant = defaultFloat
+  vtEltType _ = VT_R4
+
+instance Variant Double where
+  inVariant   = inDouble
+  resVariant  = resDouble
+  defaultVariant = defaultDouble
+  vtEltType _ = VT_R8
+
+instance (Variant a) => Variant (Maybe a) where
+  inVariant      = inMaybe
+  resVariant     = resMaybe
+  defaultVariant = defaultMaybe
+  vtEltType mbx  = vtEltType (f mbx)
+		    where
+		      f :: Maybe a -> a
+		      f = undefined
+
+instance Variant (Ptr a) where
+  inVariant      = \ p y -> copyVARIANT y (castPtr p)
+  resVariant     = \ p -> return (castPtr p)
+  defaultVariant = nullPtr
+  
+\end{code}
+
+Marshallers derived from instance methods:
+
+\begin{code}
+inoutVariant :: (Variant a, Variant b) => ArgInOut a b
+inoutVariant x        = (inVariant x,resVariant)
+
+inoutVariant' :: (Variant a) => ArgInOut a a
+inoutVariant' = inoutVariant
+
+outVariant :: (Variant a) => ArgOut a
+outVariant            = (inoutVariant' defaultVariant)
+\end{code}
+
+\begin{code}
+inDefaultValue :: VarIn -> ArgIn a -> ArgIn a
+inDefaultValue varin_def argin = \ val var -> do
+  argin val var
+  vt <- readVarEnum var
+  case vt of -- to avoid having to define Eq..
+    VT_ERROR -> do
+      primVARIANTClear var
+      varin_def var
+    _ -> return ()
+
+defaultMaybe :: Variant a => Maybe a
+defaultMaybe = Nothing
+
+inOptional :: VarIn -> ArgIn a -> ArgIn (Maybe a)
+inOptional varin_def argin = \val var -> do
+   case val of
+     Nothing -> varin_def var
+     Just v  -> argin v var
+
+inMaybe :: Variant a => ArgIn (Maybe a)
+inMaybe Nothing  = inEmpty ()
+inMaybe (Just x) = inVariant x
+
+resMaybe :: Variant a => ArgRes (Maybe a)
+resMaybe p = 
+  catch
+    (readVarError p >> return Nothing)
+    (\ _ -> fmap Just (resVariant p))
+
+inoutMaybe :: Variant a => ArgInOut (Maybe a) (Maybe a)
+inoutMaybe o       = (inMaybe o,resMaybe)
+
+outMaybe :: Variant a => (VarIn,ArgRes (Maybe a))
+outMaybe  = inoutMaybe defaultMaybe
+\end{code}
+
+\begin{code}
+data SqlNull     = SqlNull
+
+defaultSqlNull  :: SqlNull
+defaultSqlNull   = SqlNull
+
+inSqlNull :: ArgIn SqlNull
+inSqlNull SqlNull p   = writeVarNull p
+
+resSqlNull :: ArgRes SqlNull
+resSqlNull p          = readVarNull p >> return SqlNull
+
+inoutSqlNull SqlNull  = (inSqlNull SqlNull,resSqlNull)
+outSqlNull            = inoutSqlNull defaultSqlNull
+\end{code}
+
+Haskell values (stable ptr's). 
+
+\begin{code}
+inHaskellValue :: ArgIn a
+inHaskellValue x p = do
+   stable <- newStablePtr x
+   writeVarStablePtr stable (castPtr p)
+
+unsafeResHaskellValue :: ArgRes a
+unsafeResHaskellValue p = do
+   stable <- readVarStablePtr p
+   deRefStablePtr stable
+
+unsafeOutHaskellValue  =
+  ( \ p -> writeVarStablePtr undefinedStablePtr p
+  , unsafeResHaskellValue
+  )
+
+undefinedStablePtr :: StablePtr a
+undefinedStablePtr = unsafePerformIO (newStablePtr undefined)
+\end{code}
+
+
+Convenience QIs - are they really used?
+
+\begin{code}
+queryIUnknown :: IID (IUnknown a) -> IUnknown () -> IO (IUnknown a)
+queryIUnknown          = queryInterface
+
+queryIDispatch :: IID (IUnknown a) -> IDispatch () -> IO (IUnknown a)
+queryIDispatch         = queryInterface
+\end{code}
+
+The basic marshalling functions for automation types.
+
+\begin{code}
+defaultEmpty :: ()
+defaultEmpty            = ()
+
+inNoArg :: ArgIn ()
+inNoArg i               = writeVarOptional
+
+inEmpty :: ArgIn ()
+inEmpty i               = writeVarEmpty
+
+noInArg :: VarIn
+noInArg = inEmpty ()
+
+resEmpty :: ArgRes ()
+resEmpty p              = return ()
+
+inoutEmpty e            = (inEmpty e,resEmpty)
+outEmpty                = inoutEmpty defaultEmpty
+
+inGUID :: ArgIn GUID
+inGUID g = inString (show g)
+
+inoutGUID i           = (inGUID i,resGUID)
+outGUID                = inoutGUID nullGUID
+
+resGUID :: ArgRes GUID
+resGUID p  = resString p >>= stringToGUID
+
+\end{code}
+
+Integers.
+
+\begin{code}
+defaultInt :: Int
+defaultInt            = 0
+
+inInt :: ArgIn Int
+inInt i               = writeVarInt (fromIntegral i)
+
+resInt :: ArgRes Int
+resInt p              = readVarInt p >>= return.fromIntegral
+
+inoutInt i            = (inInt i,resInt)
+outInt                = inoutInt defaultInt
+
+defaultInt8 :: Int8
+defaultInt8        = 0
+
+inInt8 :: ArgIn Int8
+inInt8 i           = writeVarInt (fromIntegral i)
+
+resInt8 :: ArgRes Int8
+resInt8 p          = readVarInt p >>= return.fromIntegral
+
+inoutInt8 i        = (inInt8 i,resInt8)
+outInt8            = inoutInt8 defaultInt8
+
+defaultInt16 :: Int16
+defaultInt16        = 0
+
+inInt16 :: ArgIn Int16
+inInt16 i           = writeVarInt (fromIntegral i)
+
+resInt16 :: ArgRes Int16
+resInt16 p          = readVarInt p >>= return.fromIntegral
+
+inoutInt16 i        = (inInt16 i,resInt16)
+outInt16            = inoutInt16 defaultInt16
+
+defaultInt32 :: Int32
+defaultInt32        = 0
+
+inInt32 :: ArgIn Int32
+inInt32 i           = writeVarInt i
+
+resInt32 :: ArgRes Int32
+resInt32 p          = readVarInt p >>= return
+
+inoutInt32 i        = (inInt32 i,resInt32)
+outInt32            = inoutInt32 defaultInt32
+
+defaultHRESULT = defaultInt32
+inHRESULT = inInt32
+resHRESULT = resInt32
+inoutHRESULT = inoutInt32
+outHRESULT   = outInt32
+
+{- BEGIN_GHC_ONLY
+defaultInt64 :: Int64
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+defaultInt64 :: Integer
+{- END_NOT_FOR_GHC -}
+defaultInt64        = 0
+
+inInt64 :: ArgIn Currency
+inInt64 = inCurrency
+
+resInt64 :: ArgRes Currency
+resInt64 = resCurrency
+
+inoutInt64 i = (inInt64 i,resInt64)
+outInt64     = inoutInt64 defaultInt64
+
+defaultInteger = defaultInt64
+inInteger      = inInt64
+resInteger     = resInt64
+inoutInteger   = inoutInt64
+outInteger     = outInt64
+
+\end{code}
+
+Words
+
+\begin{code}
+defaultWord :: Int
+defaultWord            = 0
+
+inWord :: ArgIn Int
+inWord i               = writeVarInt (fromIntegral i)
+
+resWord :: ArgRes Int
+resWord p              = readVarInt p >>= return.fromIntegral
+
+inoutWord i            = (inInt i,resInt)
+outWord                = inoutInt defaultInt
+
+defaultWord8 :: Word8
+defaultWord8            = 0
+
+inWord8 :: ArgIn Word8
+inWord8 i               = writeVarWord (fromIntegral i)
+
+resWord8 :: ArgRes Word8
+resWord8 p              = readVarWord p >>= return.fromIntegral
+
+inoutWord8 i            = (inWord8 i,resWord8)
+outWord8                = inoutWord8 defaultWord8
+
+defaultWord16 :: Word16
+defaultWord16            = 0
+
+inWord16 :: ArgIn Word16
+inWord16 i               = writeVarWord (fromIntegral i)
+
+resWord16 :: ArgRes Word16
+resWord16 p              = readVarWord p >>= return.fromIntegral
+
+inoutWord16 i            = (inWord16 i,resWord16)
+outWord16                = inoutWord16 defaultWord16
+
+defaultWord32 :: Word32
+defaultWord32            = 0
+
+inWord32 :: ArgIn Word32
+inWord32 i               = writeVarWord i
+
+resWord32 :: ArgRes Word32
+resWord32 p              = readVarWord p
+
+inoutWord32 i            = (inWord32 i,resWord32)
+outWord32                = inoutWord32 defaultWord32
+
+{- BEGIN_GHC_ONLY
+defaultWord64 :: Word64
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+defaultWord64 :: Integer
+{- END_NOT_FOR_GHC -}
+defaultWord64            = 0
+
+{- BEGIN_GHC_ONLY
+inWord64 :: ArgIn Word64
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+inWord64 :: ArgIn Integer
+{- END_NOT_FOR_GHC -}
+inWord64 f  = 
+   let
+    (hi,lo) = toInteger f `divMod` (toInteger (maxBound :: Int) + 1)
+   in
+   writeVarWord64 (fromInteger hi) (fromInteger lo)
+
+{- BEGIN_GHC_ONLY
+resWord64 :: ArgRes Word64
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+resWord64 :: ArgRes Integer
+{- END_NOT_FOR_GHC -}
+resWord64           = 
+   let
+    coerceW = fromIntegral
+    coerceI = fromIntegral
+    
+    readWord v = do
+      (hi,lo) <- readVarWord64 v
+      return (coerceW hi * (coerceI (maxBound :: Int) + 1) + coerceW lo)
+   in
+   readWord
+
+inoutWord64 i            = (inWord64 i,resWord64)
+outWord64                = inoutWord64 defaultWord64
+
+\end{code}
+
+Bytes (yeah, I know, the name of the type was a bit of a give-away :-)
+
+\begin{code}
+--type Byte = Char
+
+defaultByte :: Byte
+defaultByte            = 0
+
+inByte :: ArgIn Byte
+inByte i               = writeVarByte i
+
+resByte :: ArgRes Byte
+resByte                = readVarByte
+
+inoutByte i            = (inByte i,resByte)
+outByte                = inoutByte defaultByte
+
+defaultChar :: Char
+defaultChar            = '\0'
+
+inChar :: ArgIn Char
+inChar i               = writeVarByte (fromIntegral (ord i))
+
+resChar :: ArgRes Char
+resChar  p             = readVarByte p >>= \ x -> return (chr (fromIntegral x))
+
+inoutChar i            = (inChar i,resChar)
+outChar                = inoutChar defaultChar
+\end{code}
+
+Booleans.
+
+\begin{code}
+defaultBool :: Bool
+defaultBool            = False
+
+inBool :: ArgIn Bool
+inBool b               = writeVarBool b
+
+resBool :: ArgRes Bool
+resBool                = readVarBool
+
+inoutBool b            = (inBool b,resBool)
+outBool                = inoutBool defaultBool
+\end{code}
+
+
+Floats.
+
+\begin{code}
+defaultFloat :: Float
+defaultFloat           = 0.0
+
+inFloat :: ArgIn Float
+inFloat f              = writeVarFloat f
+
+resFloat :: ArgRes Float
+resFloat               = readVarFloat
+
+inoutFloat b           = (inFloat b,resFloat)
+outFloat               = inoutFloat defaultFloat
+\end{code}
+
+Doubles.
+
+\begin{code}
+defaultDouble :: Double
+defaultDouble           = 0.0
+
+inDouble :: ArgIn Double
+inDouble f              = writeVarDouble f
+
+resDouble :: ArgRes Double
+resDouble               = readVarDouble
+
+inoutDouble b           = (inDouble b,resDouble)
+outDouble               = inoutDouble defaultDouble
+\end{code}
+
+Dates.
+
+\begin{code}
+type Date = Double
+
+defaultDate :: Date
+defaultDate           = 0.0
+
+inDate :: ArgIn Date
+inDate f              = writeVarDouble f
+
+resDate :: ArgRes Date
+resDate               = readVarDouble
+
+inoutDate b           = (inDate b,resDate)
+outDate               = inoutDate defaultDate
+
+--
+-- clockTimeToDate relies on a non-standard implementation of Time,
+-- i.e., one which exports ClockTime non-abstractly.
+-- 
+clockTimeToDate :: ClockTime -> IO Date
+clockTimeToDate (TOD secs _) 
+  | secs > fromIntegral (maxBound :: Int) ||
+    secs < fromIntegral (minBound :: Int) = 
+    ioError (userError "Automation.clockTimeToDate: ClockTime out of range")
+  | otherwise = primClockToDate (fromIntegral secs)
+\end{code}
+
+Currency:
+
+\begin{code}
+type Currency 
+{- BEGIN_GHC_ONLY
+   = Int64
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+   = Integer
+{- END_NOT_FOR_GHC -}
+
+defaultCurrency :: Currency
+defaultCurrency  = 0
+
+-- Note: the Int64/Integer is interpreted literally here,
+-- and no account of the implicit scaling that CURRENCY 
+-- does is taken into account. ToDo: fix.
+inCurrency :: ArgIn Currency
+inCurrency f  = 
+   let
+{- BEGIN_NOT_FOR_GHC -}
+    (hi,lo) = f `divMod` (toInteger (maxBound :: Int) + 1)
+{- END_NOT_FOR_GHC -}
+{- BEGIN_GHC_ONLY
+    (hi,lo) = f `divMod` (fromIntegral (maxBound :: Int) + 1)
+   END_GHC_ONLY -}
+   in
+   writeVarCurrency (fromIntegral (fromIntegral hi)) (fromIntegral (fromIntegral lo))
+
+
+resCurrency :: ArgRes Currency
+resCurrency           = 
+   let
+{- BEGIN_GHC_ONLY
+    coerceI = fromIntegral
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+    coerceI = toInteger
+{- END_NOT_FOR_GHC -}
+    
+    readCur v = do
+      (hi,lo) <- readVarCurrency v
+      return (coerceI (fromIntegral hi) * (coerceI (maxBound :: Int) + 1) +
+	      coerceI (fromIntegral lo))
+   in
+   readCur
+
+inoutCurrency b       = (inCurrency b, resCurrency)
+outCurrency           = inoutCurrency defaultCurrency
+\end{code}
+
+
+Strings.
+
+\begin{code}
+defaultString :: String
+defaultString            = ""
+
+inString :: ArgIn String
+inString s p           = do 
+                           pbstr  <- nofreeAllocBSTR s
+                           writeVarString (castPtr pbstr) p
+
+resString :: ArgRes String
+resString p            = readTempVar readVarString p (\ p -> unmarshallBSTR (castPtr p))
+
+inoutString i            = (inString i,resString)
+outString                = inoutString defaultString
+\end{code}
+
+Unknown objects.
+
+\begin{code}
+defaultIUnknown :: IUnknown a
+defaultIUnknown          = interfaceNULL
+
+inIUnknown :: ArgIn (IUnknown a)
+inIUnknown u p
+  | isNullInterface u = return ()
+  | otherwise         = do 
+                             u # addRef
+                             writeVarUnknown (castIface u) p
+
+
+resIUnknown :: ArgRes (IUnknown a)
+resIUnknown p = 
+  readTempVar readVarUnknown p (unmarshallIUnknown True{-finalise-})
+
+inoutIUnknown d          = (inIUnknown d,resIUnknown)
+outIUnknown              = inoutIUnknown defaultIUnknown
+\end{code}
+
+Dispatch objects.
+
+\begin{code}
+defaultIDispatch :: IDispatch a
+defaultIDispatch          = interfaceNULL
+
+inIDispatch :: ArgIn (IDispatch a)
+inIDispatch d p
+  | isNullInterface d = return ()
+  | otherwise         = do 
+                             d # addRef
+                             writeVarDispatch (castIface d) p
+
+resIDispatch :: ArgRes (IDispatch a)
+resIDispatch p    = 
+   readTempVar readVarDispatch p (unmarshallIUnknown True{-finalise-})
+
+inoutIDispatch d  = (inIDispatch d,resIDispatch)
+outIDispatch      = inoutIDispatch defaultIDispatch
+\end{code}
+
+Error objects.
+
+\begin{code}
+defaultError :: Int32
+defaultError         = 0
+
+inError :: ArgIn Int32
+inError d p          = writeVarError d p
+
+resError :: ArgRes Int32
+resError p           = readVarError p
+
+inoutError d          = (inError d,resError)
+outError              = inoutError defaultError
+\end{code}
+
+Generic wrappers for Enum instances
+
+\begin{code}
+inEnum :: Enum a => ArgIn a
+inEnum e = inInt (fromEnum e)
+
+defaultEnum  :: Enum a => a
+defaultEnum  = toEnum 0
+
+resEnum      :: Enum a => ArgRes a
+resEnum p    = readVarInt p >>= return.toEnum.fromIntegral
+inoutEnum    :: Enum a => ArgInOut a a
+inoutEnum i  = (inEnum i,resEnum)
+outEnum      :: Enum a => ArgOut a
+outEnum      = inoutEnum defaultEnum
+vtTypeEnum   :: Enum a => a -> VARENUM
+vtTypeEnum _ = VT_I4
+
+{- Support for overlapping instances required
+   to compile this one - let's not demand that 
+   being supported for now.
+   
+   If you do uncomment this one, you probably
+   also want to invoke the IDL compiler with
+   -fno-variant-enum-instances.
+
+instance Enum a => Variant a where
+  inVariant   = inEnum
+  resVariant  = resEnum
+  defaultVariant = defaultEnum
+
+  vtEltType _ = VT_I4
+-}
+\end{code}
+
+Setting and Getting properties: @getVisible = propertyGet "Visible" [] outBool@.
+
+\begin{code}
+propertyGet :: Member -> [VarIn] -> ArgOut a -> IDispatch d -> IO a
+propertyGet member argsin argout obj
+      = do dispid <- obj # getMemberID member
+           propertyGetID dispid argsin argout obj
+
+propertyGet2 :: Member -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> IDispatch d -> IO (a1,a2)
+propertyGet2 member argsin argout1 argout2 obj
+      = do dispid <- obj # getMemberID member
+           propertyGet2ID dispid argsin argout1 argout2 obj
+
+propertyGet3 :: Member -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> ArgOut a3 -> IDispatch d -> IO (a1,a2,a3)
+propertyGet3 member argsin argout1 argout2 argout3 obj
+      = do dispid <- obj # getMemberID member
+           propertyGet3ID dispid argsin argout1 argout2 argout3 obj
+
+propertyGet4 :: Member -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> ArgOut a3 -> ArgOut a4 -> IDispatch d -> IO (a1,a2,a3,a4)
+propertyGet4 member argsin argout1 argout2 argout3 argout4 obj
+      = do dispid <- obj # getMemberID member
+           propertyGet4ID dispid argsin argout1 argout2 argout3 argout4 obj
+
+propertySet :: Member -> [VarIn] -> IDispatch d -> IO ()
+propertySet member argsin obj
+      = do dispid <- obj # getMemberID member
+           propertySetID dispid argsin obj
+
+propertySetGet :: Member -> [VarIn] -> ArgOut a -> IDispatch d -> IO a
+propertySetGet member argsin argout obj
+      = do dispid <- obj # getMemberID member
+           propertySetGetID dispid argsin argout obj
+
+propertyGetID :: DISPID -> [VarIn] -> ArgOut a -> IDispatch d -> IO a
+propertyGetID dispid argsin (varin,argres) obj
+      = do p <- obj # invokePropertyGet dispid argsin [varin]
+           unmarshallVariants1 argres p
+
+propertyGet2ID :: DISPID -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> IDispatch d -> IO (a1,a2)
+propertyGet2ID dispid argsin (varin1,argres1) (varin2,argres2) obj
+      = do p <- obj # invokePropertyGet dispid argsin [varin1,varin2]
+           unmarshallVariants2 argres1 argres2 p
+
+propertyGet3ID :: DISPID -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> ArgOut a3 -> IDispatch d -> IO (a1,a2,a3)
+propertyGet3ID dispid argsin (varin1,argres1) (varin2,argres2) (varin3,argres3) obj
+      = do p <- obj # invokePropertyGet dispid argsin [varin1,varin2,varin3]
+           unmarshallVariants3 argres1 argres2 argres3 p
+
+propertyGet4ID :: DISPID -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> ArgOut a3 -> ArgOut a4 -> IDispatch d -> IO (a1,a2,a3,a4)
+propertyGet4ID dispid argsin (varin1,argres1) (varin2,argres2) (varin3,argres3) (varin4,argres4) obj
+      = do p <- obj # invokePropertyGet dispid argsin [varin1,varin2,varin3,varin4]
+           unmarshallVariants4 argres1 argres2 argres3 argres4 p
+
+propertySetID :: DISPID -> [VarIn] -> IDispatch d -> IO ()
+propertySetID dispid argsin obj
+      = do p <- obj # invokePropertySet dispid argsin []
+           unmarshallVariants0 p
+
+propertySetGetID :: DISPID -> [VarIn] -> ArgOut a -> IDispatch d -> IO a
+propertySetGetID dispid argsin (varin,argres) obj
+      = do p <- obj # invokePropertySet dispid argsin [varin]
+           unmarshallVariants1 argres p
+\end{code}
+
+Methods and functions are defined using @method@/@funtion@. The digit
+appended to the name gives the number of results.
+For example: @confirm msg  = function1 "Confirm" [inString msg] outBool@.
+
+\begin{code}
+method0 :: Member
+        -> [VarIn]
+	-> IDispatch i
+	-> IO ()
+method0 member args obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (methodID0 dispid args obj)
+
+method1 :: Member
+        -> [VarIn]
+	-> ArgOut a1
+	-> IDispatch i
+	-> IO a1
+method1 member args argout obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (methodID1 dispid args argout obj)
+
+method2 :: Member
+        -> [VarIn]
+	-> ArgOut a1
+	-> ArgOut a2
+	-> IDispatch i
+	-> IO (a1,a2)
+method2 member args argout1 argout2 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (methodID2 dispid args argout1 argout2 obj)
+
+method3 :: Member
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+        -> IDispatch i -> IO (a1,a2,a3)
+method3 member args argout1 argout2 argout3 obj = do 
+    dispid <- obj # getMemberID member
+    catchMethError member (methodID3 dispid args argout1 argout2 argout3 obj)
+
+method4 :: Member
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 
+	-> ArgOut a3 -> ArgOut a4
+        -> IDispatch i -> IO (a1,a2,a3,a4)
+method4 member args argout1 argout2 argout3 argout4 obj = do
+    dispid <- obj # getMemberID member
+    catchMethError member $
+      methodID4 dispid args argout1 argout2 argout3 argout4 obj
+
+method5 :: Member 
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	-> ArgOut a4 -> ArgOut a5
+        -> IDispatch i -> IO (a1,a2,a3,a4,a5)
+method5 member args argout1 argout2 argout3 argout4 argout5 obj = do
+    dispid <- obj # getMemberID member
+    catchMethError member $
+      methodID5 dispid args argout1 argout2 argout3 argout4 argout5 obj
+
+method6 :: Member 
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 -> ArgOut a3 
+	-> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+        -> IDispatch i
+	-> IO (a1,a2,a3,a4,a5,a6)
+method6 member args argout1 argout2 argout3 argout4 argout5 argout6 obj = do
+    dispid <- obj # getMemberID member
+    catchMethError member $
+      methodID6 dispid args argout1 argout2 argout3
+                            argout4 argout5 argout6 obj
+
+method7 :: Member 
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	-> ArgOut a4 -> ArgOut a5 -> ArgOut a6 -> ArgOut a7
+        -> IDispatch i -> IO (a1, a2, a3, a4, a5, a6, a7)
+method7 member args argout1 argout2 argout3 argout4 argout5 argout6 argout7 obj = do
+    dispid <- obj # getMemberID member
+    catchMethError member $
+          methodID7 dispid args argout1 argout2 argout3
+	                        argout4 argout5 argout6 argout7 obj
+
+method8 :: Member
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	-> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+	-> ArgOut a7 -> ArgOut a8
+        -> IDispatch i 
+	-> IO (a1, a2, a3, a4, a5, a6, a7, a8)
+method8 member args argout1 argout2 argout3 
+                    argout4 argout5 argout6 
+		    argout7 argout8 obj = do
+    dispid <- obj # getMemberID member
+    catchMethError member $
+      methodID8 dispid args argout1 argout2 argout3 
+                            argout4 argout5 argout6 
+			    argout7 argout8 obj
+
+\end{code}
+
+Methods invoked on DISPID.
+
+\begin{code}
+methodID0 :: DISPID
+          -> [VarIn]
+	  -> IDispatch i
+	  -> IO ()
+methodID0 dispid args obj = do
+   p <- obj # invokeMethod dispid args []
+   unmarshallVariants0 p
+
+methodID1 :: DISPID
+          -> [VarIn]
+	  -> ArgOut a1
+	  -> IDispatch i
+	  -> IO a1
+methodID1 dispid args (varin,argres) obj = do
+   p <- obj # invokeMethod dispid args [varin]
+   unmarshallVariants1 argres p
+
+methodID2 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2
+	  -> IDispatch i
+	  -> IO (a1,a2)
+methodID2 dispid args (varin1,argres1) (varin2,argres2) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2]
+   unmarshallVariants2 argres1 argres2 p
+
+methodID3 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> IDispatch i
+	  -> IO (a1,a2,a3)
+methodID3 dispid args (varin1,argres1) (varin2,argres2) (varin3,argres3) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3]
+   unmarshallVariants3 argres1 argres2 argres3 p
+
+methodID4 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4
+          -> IDispatch i
+	  -> IO (a1,a2,a3,a4)
+methodID4 dispid args (varin1,argres1) (varin2,argres2)
+                      (varin3,argres3) (varin4,argres4) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3,varin4]
+   unmarshallVariants4 argres1 argres2 argres3 argres4 p
+
+methodID5 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5
+          -> IDispatch i 
+	  -> IO (a1,a2,a3,a4,a5)
+methodID5 dispid args (varin1,argres1) (varin2,argres2)
+                      (varin3,argres3) (varin4,argres4)
+		      (varin5,argres5) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3,varin4,varin5]
+   unmarshallVariants5 argres1 argres2 argres3 argres4 argres5 p
+
+
+methodID6 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+          -> IDispatch i
+	  -> IO (a1,a2,a3,a4,a5,a6)
+methodID6 dispid args (varin1,argres1) (varin2,argres2)
+                      (varin3,argres3) (varin4,argres4)
+		      (varin5,argres5) (varin6,argres6) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3,varin4,varin5,varin6]
+   unmarshallVariants6 argres1 argres2 argres3 argres4 argres5 argres6 p
+
+methodID7 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+	  -> ArgOut a7
+          -> IDispatch i 
+	  -> IO (a1,a2,a3,a4,a5,a6,a7)
+methodID7 dispid args (varin1,argres1) (varin2,argres2)
+                      (varin3,argres3) (varin4,argres4)
+		      (varin5,argres5) (varin6,argres6)
+		      (varin7,argres7) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3,varin4,varin5,varin6,varin7]
+   unmarshallVariants7 argres1 argres2 argres3 argres4 argres5 argres6 argres7 p
+
+methodID8 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+	  -> ArgOut a7 -> ArgOut a8
+	  -> IDispatch i
+	  -> IO (a1,a2,a3,a4,a5,a6,a7,a8)
+methodID8 dispid args (varin1,argres1) (varin2,argres2)
+                      (varin3,argres3) (varin4,argres4)
+		      (varin5,argres5) (varin6,argres6)
+		      (varin7,argres7) (varin8,argres8) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3,varin4,varin5,varin6,varin7,varin8]
+   unmarshallVariants8 argres1 argres2 argres3 argres4 argres5 argres6 argres7 argres8 p
+
+\end{code}
+
+Functions. Of course @function0@ is missing. The difference with
+methods is that functions expect the last @out@ argument to be
+a result (@retval@) instead of a real @out@ argument.
+
+\begin{code}
+function1 :: Member
+          -> [VarIn]
+	  -> ArgOut a1
+	  -> IDispatch i
+	  -> IO a1
+function1 member args argout obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (functionID1 dispid args argout obj)
+
+function2 :: Member
+          -> [VarIn]
+	  -> ArgOut a1 -> ArgOut a2
+	  -> IDispatch i
+	  -> IO (a1,a2)
+function2 member args argout1 argout2 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (functionID2 dispid args argout1 argout2 obj)
+
+function3 :: Member
+          -> [VarIn]
+	  -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> IDispatch i
+	  -> IO (a1,a2,a3)
+function3 member args argout1 argout2 argout3 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (functionID3 dispid args argout1 argout2 argout3 obj)
+
+function4 :: Member
+          -> [VarIn]
+	  -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4
+	  -> IDispatch i
+	  -> IO (a1,a2,a3,a4)
+function4 member args argout1 argout2 argout3 argout4 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (functionID4 dispid args argout1 argout2 argout3 argout4 obj)
+
+function5 :: Member
+          -> [VarIn]
+	  -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5
+	  -> IDispatch i
+	  -> IO (a1,a2,a3,a4,a5)
+function5 member args argout1 argout2 argout3 
+		      argout4 argout5 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member $
+     functionID5 dispid args argout1 argout2 argout3 argout4 argout5 obj
+
+function6 :: Member
+          -> [VarIn]
+	  -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+	  -> IDispatch i
+	  -> IO (a1,a2,a3,a4,a5,a6)
+function6 member args argout1 argout2 argout3 
+		      argout4 argout5 argout6 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member $
+     functionID6 dispid args argout1 argout2 argout3 argout4 argout5 argout6 obj
+
+functionID1 :: DISPID
+            -> [VarIn]
+	    -> ArgOut a1
+	    -> IDispatch i
+	    -> IO a1
+functionID1 dispid args (varin,argres) obj = do
+   p <- obj # invokeFunction dispid args [varin]
+   unmarshallVariants1 argres p
+
+functionID2 :: DISPID
+            -> [VarIn]
+            -> ArgOut a1 -> ArgOut a2
+	    -> IDispatch i
+	    -> IO (a1,a2)
+functionID2 dispid args (varin1,argres1) (varin2,argres2) obj = do
+   p <- obj # invokeFunction dispid args [varin1,varin2]
+   unmarshallVariants2 argres1 argres2 p
+
+functionID3 :: DISPID
+            -> [VarIn]
+            -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	    -> IDispatch i
+	    -> IO (a1,a2,a3)
+functionID3 dispid args (varin1,argres1) (varin2,argres2)
+                        (varin3,argres3) obj = do
+   p <- obj # invokeFunction dispid args [varin1,varin2,varin3]
+   unmarshallVariants3 argres1 argres2 argres3 p
+
+functionID4 :: DISPID
+            -> [VarIn]
+            -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	    -> ArgOut a4 
+	    -> IDispatch i
+	    -> IO (a1,a2,a3,a4)
+functionID4 dispid args (varin1,argres1) (varin2,argres2)
+                        (varin3,argres3) (varin4,argres4) obj = do
+   p <- obj # invokeFunction dispid args [varin1,varin2,varin3,varin4]
+   unmarshallVariants4 argres1 argres2 argres3 argres4 p
+
+functionID5 :: DISPID
+            -> [VarIn]
+            -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	    -> ArgOut a4 -> ArgOut a5
+            -> IDispatch i
+	    -> IO (a1,a2,a3,a4,a5)
+functionID5 dispid args (varin1,argres1) (varin2,argres2)
+                        (varin3,argres3) (varin4,argres4)
+			(varin5,argres5) obj = do
+   p <- obj # invokeFunction dispid args [varin1,varin2,varin3,varin4,varin5]
+   unmarshallVariants5 argres1 argres2 argres3 argres4 argres5 p
+
+functionID6 :: DISPID
+            -> [VarIn]
+            -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	    -> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+            -> IDispatch i
+	    -> IO (a1,a2,a3,a4,a5,a6)
+functionID6 dispid args (varin1,argres1) (varin2,argres2)
+                        (varin3,argres3) (varin4,argres4)
+			(varin5,argres5) (varin6,argres6) obj = do
+   p <- obj # invokeFunction dispid args [varin1,varin2,varin3,varin4,varin5,varin6]
+   unmarshallVariants6 argres1 argres2 argres3 argres4 argres5 argres6 p
+
+\end{code}
+
+Error reporting:
+
+\begin{code}
+errorMember :: String -> IOError -> IO a
+errorMember member err
+      = coFail ("method '" ++ member ++ "': " ++ (coGetErrorString err))
+
+catchMethError :: Member -> IO a -> IO a
+catchMethError member act = catch act (errorMember member)
+
+\end{code}
+
+Unmarshall the @out@ arguments.
+
+\begin{code}
+unmarshallVariants0 p 
+      = readVariants0 p `always` freeMemVariants 0 p
+
+unmarshallVariants1 a p
+      = readVariants1 a p `always` freeMemVariants 1 p
+
+unmarshallVariants2   a b p
+      = readVariants2 a b p `always` freeMemVariants 2 p
+
+unmarshallVariants3   a b c p
+      = readVariants3 a b c p `always` freeMemVariants 3 p
+
+unmarshallVariants4   a b c d p
+      = readVariants4 a b c d p `always` freeMemVariants 4 p
+
+unmarshallVariants5   a b c d e p
+      = readVariants5 a b c d e p `always` freeMemVariants 5 p
+
+unmarshallVariants6   a b c d e f p
+      = readVariants6 a b c d e f p `always` freeMemVariants 6 p
+
+unmarshallVariants7   a b c d e f g p
+      = readVariants7 a b c d e f g p `always` freeMemVariants 7 p
+
+unmarshallVariants8   a b c d e f g h p
+      = readVariants8 a b c d e f g h p `always` freeMemVariants 8 p
+
+
+readVariants0 :: VARIANT -> IO ()
+readVariants0 p = return ()
+
+readVariants1 :: ArgRes a -> VARIANT  -> IO a
+readVariants1 f p = f p
+
+readVariants2 :: ArgRes a -> ArgRes b -> VARIANT  -> IO (a,b)
+readVariants2 f g p
+      = do y <- g p
+           x <- f (p `addNCastPtr` sizeofVARIANT)
+           return (x,y)
+
+readVariants3 :: ArgRes a -> ArgRes b -> ArgRes c
+                      -> VARIANT  -> IO (a,b,c)
+readVariants3 f g h p
+      = do z <- h p
+           y <- g (p `addNCastPtr` sizeofVARIANT)
+           x <- f (p `addNCastPtr` (2*sizeofVARIANT))
+           return (x,y,z)
+
+readVariants4 :: ArgRes a -> ArgRes b -> ArgRes c -> ArgRes d
+                      -> VARIANT  -> IO (a,b,c,d)
+readVariants4 f g h i p
+      = do z <- i p
+           y <- h (p `addNCastPtr` sizeofVARIANT)
+           x <- g (p `addNCastPtr` (2*sizeofVARIANT))
+           w <- f (p `addNCastPtr` (3*sizeofVARIANT))
+           return (w,x,y,z)
+
+readVariants5 :: ArgRes a -> ArgRes b -> ArgRes c -> ArgRes d -> ArgRes e
+                      -> VARIANT  -> IO (a,b,c,d,e)
+readVariants5 f g h i j p
+      = do z <- j p
+           y <- i (p `addNCastPtr` sizeofVARIANT)
+           x <- h (p `addNCastPtr` (2*sizeofVARIANT))
+           w <- g (p `addNCastPtr` (3*sizeofVARIANT))
+           v <- f (p `addNCastPtr` (4*sizeofVARIANT))
+           return (v,w,x,y,z)
+
+readVariants6 :: ArgRes a1 
+	      -> ArgRes a2
+	      -> ArgRes a3
+	      -> ArgRes a4
+	      -> ArgRes a5
+	      -> ArgRes a6
+              -> VARIANT
+	      -> IO (a1,a2,a3,a4,a5,a6)
+readVariants6 f1 f2 f3 f4 f5 f6 p
+      = do v6 <- f6 p
+           v5 <- f5 (p `addNCastPtr` sizeofVARIANT)
+           v4 <- f4 (p `addNCastPtr` (2*sizeofVARIANT))
+           v3 <- f3 (p `addNCastPtr` (3*sizeofVARIANT))
+           v2 <- f2 (p `addNCastPtr` (4*sizeofVARIANT))
+           v1 <- f1 (p `addNCastPtr` (5*sizeofVARIANT))
+           return (v1,v2,v3,v4,v5,v6)
+
+readVariants7 :: ArgRes a1 -> ArgRes a2 -> ArgRes a3 -> ArgRes a4 -> ArgRes a5 
+                      -> ArgRes a6 -> ArgRes a7
+                      -> VARIANT  -> IO (a1,a2,a3,a4,a5,a6,a7)
+readVariants7 f1 f2 f3 f4 f5 f6 f7 p
+      = do v7 <- f7 p
+           v6 <- f6 (p `addNCastPtr` sizeofVARIANT)
+           v5 <- f5 (p `addNCastPtr` (2*sizeofVARIANT))
+           v4 <- f4 (p `addNCastPtr` (3*sizeofVARIANT))
+           v3 <- f3 (p `addNCastPtr` (4*sizeofVARIANT))
+           v2 <- f2 (p `addNCastPtr` (5*sizeofVARIANT))
+           v1 <- f1 (p `addNCastPtr` (6*sizeofVARIANT))
+           return (v1,v2,v3,v4,v5,v6,v7)
+
+readVariants8:: ArgRes a1 -> ArgRes a2 -> ArgRes a3 -> ArgRes a4 -> ArgRes a5 
+                      -> ArgRes a6 -> ArgRes a7 -> ArgRes a8
+                      -> VARIANT  -> IO (a1,a2,a3,a4,a5,a6,a7,a8)
+readVariants8 f1 f2 f3 f4 f5 f6 f7 f8 p
+      = do v8 <- f8 p
+           v7 <- f7 (p `addNCastPtr` sizeofVARIANT)
+           v6 <- f6 (p `addNCastPtr` (2*sizeofVARIANT))
+           v5 <- f5 (p `addNCastPtr` (3*sizeofVARIANT))
+           v4 <- f4 (p `addNCastPtr` (4*sizeofVARIANT))
+           v3 <- f3 (p `addNCastPtr` (5*sizeofVARIANT))
+           v2 <- f2 (p `addNCastPtr` (6*sizeofVARIANT))
+           v1 <- f1 (p `addNCastPtr` (7*sizeofVARIANT))
+           return (v1,v2,v3,v4,v5,v6,v7,v8)
+
+{- UNUSED:
+unmarshallVariantList :: [ArgRes a] -> VARIANT  -> IO [a]
+unmarshallVariantList fls p = 
+   (go p fls []) `always` freeMemVariants len p
+  where
+    len = length fls
+
+    go p [] acc     = return acc
+    go p (f:fs) acc = do
+        v <- f p
+        go (p `addNCastPtr` sizeofVARIANT) fs (v:acc)
+-}
+\end{code}
+
+@invokeMethod/Function@ and @propertyGet/Set@ all use the primitive
+@primInvokeMethod@.
+
+\begin{code}
+invokePropertyGet     = primInvokeMethod dispPROPERTYGET True
+invokePropertySet     = primInvokeMethod dispPROPERTYSET False
+invokeMethod          = primInvokeMethod dispMETHOD False
+invokeFunction        = primInvokeMethod dispMETHOD True
+\end{code}
+
+Some constants used with the invoke functions.
+
+\begin{code}
+type DispAction         = Word32
+
+dispMETHOD :: Word32
+dispMETHOD              = 1
+dispPROPERTYGET :: Word32
+dispPROPERTYGET         = 2
+dispPROPERTYSET :: Word32
+dispPROPERTYSET         = 4
+dispPROPERTYSETREF :: Word32
+dispPROPERTYSETREF      = 8
+
+lcidNeutral :: Word32
+lcidNeutral             = 0
+\end{code}
+
+The primitive invokation mechanism. Exceptions are directed to the normal
+@coFail@ function.
+
+\begin{code}
+primInvokeMethod :: DispAction 
+	         -> Bool
+		 -> DISPID
+                 -> [VarIn] -> [VarIn]
+                 -> IDispatch d 
+		 -> IO (VARIANT)
+primInvokeMethod action isfunction dispid argin argout iptr
+      = let cargsout = fromIntegral (length argout)
+            cargs    = cargsout + fromIntegral (length argin)
+        in
+           stackFrame (fromIntegral (sizeofVARIANT * fromIntegral cargs)) $ \ pargs ->
+        do
+           pargout      <- allocMemory (fromIntegral $ sizeofVARIANT * fromIntegral cargsout)
+           let pargin   = pargs `addNCastPtr` (sizeofVARIANT * fromIntegral cargsout)
+
+           writeSeqAtDec (fromIntegral sizeofVARIANT) argin  pargin
+           writeSeqAtDec (fromIntegral sizeofVARIANT) argout pargout
+
+           (pinfo,hr) <- dispatchInvoke (castIface iptr)
+                              dispid lcidNeutral isfunction
+                              action (fromIntegral cargs) 
+			      cargsout
+                              pargs pargout
+
+           if (succeeded hr)
+            then return pargout
+            else if hr == dISP_E_EXCEPTION
+                  then do 
+                          pstr <- getExcepInfoMessage pinfo
+			  str  <- unmarshallString (castPtr pstr)
+			  coFree pstr
+                          freeExcepInfo pinfo
+                          freeMemory pinfo
+                          freeMemVariants cargsout pargout
+                          coFail str
+                  else do 
+                          putMessage "invoke failed"
+                          freeMemVariants cargsout pargout
+                          coFailHR hr
+\end{code}
+
+Some helper functions for @Variants@.
+
+\begin{code}
+readTempVar :: (VARIANT -> IO (Ptr (Ptr b), Ptr (VARIANT)))
+	    -> VARIANT
+	    -> (Ptr b -> IO d)
+	    -> IO d
+readTempVar io p f
+      = do (x,v) <- io p
+           x <- readPtr x  -- we always get a ty* back, so dereference it before using.
+           f x  `always` (freeVariants 1 (castPtr v) >> free v) 
+	       -- _don't_ use freeMemVariants, as it ends up
+	       -- calling freeMemory (==CoTaskMemFree()),
+	       -- which isn't right ('v' is allocated by malloc()).
+
+freeMemVariants count p = do
+      freeVariants count p
+      freeMemory p
+
+\end{code}
+
+Marshall BSTR values. @allocBSTR@ is called @primAllocBSTR@
+since it doesn't take care of freeing the string. (If we
+just had true foreign objects: @mkPointer xbstr freeBSTR@.)
+
+\begin{code}
+allocBSTR :: String -> IO (Ptr String)
+allocBSTR s             = stackString s $ \ _ pstr -> do
+                            ptr <- stringToBSTR (castPtr pstr)
+			    readPtr ptr
+
+nofreeAllocBSTR :: String -> IO (Ptr String)
+nofreeAllocBSTR s       = stackString s $ \ _ pstr -> do
+                            ptr <- nofreeBstrFromString (castPtr pstr)
+			    return ptr
+--			    makePointer finalFreeBSTR ptr
+
+nofreeBstrFromString :: Ptr String -> IO (Ptr String)
+nofreeBstrFromString str = do
+   ptr <- stringToBSTR str
+   readPtr ptr
+
+data EnumVARIANT a      = EnumVARIANT
+type IEnumVARIANT a     = IUnknown (EnumVARIANT a)
+iidIEnumVARIANT :: IID (IEnumVARIANT ())
+iidIEnumVARIANT = mkIID "{00020404-0000-0000-C000-000000000046}"
+
+newEnum :: IDispatch a -> IO (Int, IEnumVARIANT b)
+newEnum ip = do
+  iunk  <- ip   # function1 "_NewEnum" [] outIUnknown
+  ienum <- iunk # queryInterface iidIEnumVARIANT
+  len   <- ip   # propertyGet "length" [] outInt
+  return (len, castIface ienum)
+  
+
+enumVariants :: Variant a => IDispatch b -> IO [a]
+enumVariants ip = do
+     (len, ienum) <- newEnum ip
+     enumNext (fromIntegral sizeofVARIANT) resVariant (fromIntegral len) ienum
+
+\end{code}
+
+Helpers
+
+\begin{code}
+always :: IO a -> IO () -> IO a
+always io action = do
+  x <- io `catch` (\ e -> action >> ioError e)
+  action
+  return x
+
+\end{code}
+
+\begin{code}
+{- BEGIN_GHC_ONLY
+marshallCurrency = marshallInt64
+unmarshallCurrency = unmarshallInt64
+readCurrency = readInt64
+writeCurrency = writeInt64
+   END_GHC_ONLY -}
+sizeofCurrency = sizeofInt64
+
+\end{code}
+
+\begin{code}
+data VARENUM
+ = VT_EMPTY
+ | VT_NULL
+ | VT_I2
+ | VT_I4
+ | VT_R4
+ | VT_R8
+ | VT_CY
+ | VT_DATE
+ | VT_BSTR
+ | VT_DISPATCH
+ | VT_ERROR
+ | VT_BOOL
+ | VT_VARIANT
+ | VT_UNKNOWN
+ | VT_DECIMAL
+ | VT_I1
+ | VT_UI1
+ | VT_UI2
+ | VT_UI4
+ | VT_I8
+ | VT_UI8
+ | VT_INT
+ | VT_UINT
+ | VT_VOID
+ | VT_HRESULT
+ | VT_PTR
+ | VT_SAFEARRAY
+ | VT_CARRAY
+ | VT_USERDEFINED
+ | VT_LPSTR
+ | VT_LPWSTR
+ | VT_FILETIME
+ | VT_BLOB
+ | VT_STREAM
+ | VT_STORAGE
+ | VT_STREAMED_OBJECT
+ | VT_STORED_OBJECT
+ | VT_BLOB_OBJECT
+ | VT_CF
+ | VT_CLSID
+ | VT_BSTR_BLOB
+ | VT_VECTOR
+ | VT_ARRAY
+ | VT_BYREF
+ | VT_RESERVED
+ | VT_ILLEGAL
+ | VT_ILLEGALMASKED
+ | VT_TYPEMASK
+   deriving ( Eq, Show )
+ 
+instance Enum VARENUM where
+  fromEnum vt = 
+   case vt of 
+     VT_EMPTY ->  0
+     VT_NULL ->  1
+     VT_I2 ->  2
+     VT_I4 ->  3
+     VT_R4 ->  4
+     VT_R8 ->  5
+     VT_CY ->  6
+     VT_DATE ->  7
+     VT_BSTR ->  8
+     VT_DISPATCH ->  9
+     VT_ERROR ->  10
+     VT_BOOL ->  11
+     VT_VARIANT ->  12
+     VT_UNKNOWN ->  13
+     VT_DECIMAL ->  14
+     VT_I1 ->  16
+     VT_UI1 ->  17
+     VT_UI2 ->  18
+     VT_UI4 ->  19
+     VT_I8 ->  20
+     VT_UI8 ->  21
+     VT_INT ->  22
+     VT_UINT ->  23
+     VT_VOID ->  24
+     VT_HRESULT ->  25
+     VT_PTR ->  26
+     VT_SAFEARRAY ->  27
+     VT_CARRAY ->  28
+     VT_USERDEFINED ->  29
+     VT_LPSTR ->  30
+     VT_LPWSTR ->  31
+     VT_FILETIME ->  64
+     VT_BLOB ->  65
+     VT_STREAM ->  66
+     VT_STORAGE ->  67
+     VT_STREAMED_OBJECT ->  68
+     VT_STORED_OBJECT ->  69
+     VT_BLOB_OBJECT ->  70
+     VT_CF ->  71
+     VT_CLSID ->  72
+     VT_BSTR_BLOB ->  4095
+     VT_VECTOR ->  4096
+     VT_ARRAY ->  8192
+     VT_BYREF ->  16384
+     VT_RESERVED ->  32768
+     VT_ILLEGAL ->  65535
+     VT_ILLEGALMASKED ->  4095
+     VT_TYPEMASK ->  4095
+
+  toEnum v =
+   case v of
+     0 -> VT_EMPTY
+     1 -> VT_NULL
+     2 -> VT_I2
+     3 -> VT_I4
+     4 -> VT_R4
+     5 -> VT_R8
+     6 -> VT_CY
+     7 -> VT_DATE
+     8 -> VT_BSTR
+     9 -> VT_DISPATCH
+     10 -> VT_ERROR
+     11 -> VT_BOOL
+     12 -> VT_VARIANT
+     13 -> VT_UNKNOWN
+     14 -> VT_DECIMAL
+     16 -> VT_I1
+     17 -> VT_UI1
+     18 -> VT_UI2
+     19 -> VT_UI4
+     20 -> VT_I8
+     21 -> VT_UI8
+     22 -> VT_INT
+     23 -> VT_UINT
+     24 -> VT_VOID
+     25 -> VT_HRESULT
+     26 -> VT_PTR
+     27 -> VT_SAFEARRAY
+     28 -> VT_CARRAY
+     29 -> VT_USERDEFINED
+     30 -> VT_LPSTR
+     31 -> VT_LPWSTR
+     64 -> VT_FILETIME
+     65 -> VT_BLOB
+     66 -> VT_STREAM
+     67 -> VT_STORAGE
+     68 -> VT_STREAMED_OBJECT
+     69 -> VT_STORED_OBJECT
+     70 -> VT_BLOB_OBJECT
+     71 -> VT_CF
+     72 -> VT_CLSID
+     4095 -> VT_BSTR_BLOB
+     4096 -> VT_VECTOR
+     8192 -> VT_ARRAY
+     16384 -> VT_BYREF
+     32768 -> VT_RESERVED
+     65535 -> VT_ILLEGAL
+     4095 -> VT_ILLEGALMASKED
+     4095 -> VT_TYPEMASK
+     _   
+       | v' .&. 26    == 26    -> VT_PTR   -- ho-hum.
+       | v' .&. 8192  == 8192  -> VT_ARRAY -- ho-hum.
+       | v' .&. 16384 == 16384 -> toEnum (v-16384) -- drop the VT_BYREF flag.
+       | otherwise -> error ("unmarshallVARENUM: illegal enum value " ++ show v)
+   where
+     v' = (fromIntegral v :: Int32)
+
+unmarshallVARENUM :: Int16 -> IO VARENUM
+unmarshallVARENUM v = return (toEnum (fromIntegral v))
+
+marshallVARENUM :: VARENUM -> IO Int16
+marshallVARENUM v = return (fromIntegral (fromEnum v))
+
+writeVARENUM :: Ptr Int16 -> VARENUM -> IO ()
+writeVARENUM = HDirect.writeenum16 marshallVARENUM
+
+readVARENUM :: Ptr Int16 -> IO VARENUM
+readVARENUM = HDirect.readenum16 unmarshallVARENUM
+
+sizeofVARENUM :: Word32
+sizeofVARENUM = sizeofInt16
+
+sizeofVARIANT_BOOL :: Word32
+sizeofVARIANT_BOOL = sizeofInt16
+
+marshallVARIANT_BOOL :: Bool -> IO Int16
+marshallVARIANT_BOOL True  = return minBound
+marshallVARIANT_BOOL False = return 0
+
+unmarshallVARIANT_BOOL :: Int16 -> IO Bool
+unmarshallVARIANT_BOOL 0  = return False
+unmarshallVARIANT_BOOL _  = return True
+
+writeVARIANT_BOOL :: Ptr Int16 -> Bool -> IO ()
+writeVARIANT_BOOL ptr v = marshallVARIANT_BOOL v >>= writeInt16 ptr
+
+readVARIANT_BOOL :: Ptr Int16 -> IO Bool
+readVARIANT_BOOL ptr = do
+  x <- readInt16 ptr
+  unmarshallVARIANT_BOOL x
+
+vARIANT_TRUE :: Int
+vARIANT_TRUE = -1
+
+vARIANT_FALSE :: Int
+vARIANT_FALSE = 0
+
+readVarEnum :: VARIANT -> IO VARENUM
+readVarEnum v = do
+  vt <- readVariantTag v
+  return (toEnum (fromIntegral vt))
+
+\end{code}
+
+\begin{code}
+data SafeArray a = SA SAFEARRAY
+
+mkSafeArray :: (Variant a) => SAFEARRAY -> SafeArray a
+mkSafeArray s = SA s
+
+defaultSafeArray :: Variant a => SafeArray a
+defaultSafeArray = SA (addrToSAFEARRAY nullPtr)
+
+inSafeArray :: Variant a => ArgIn (SafeArray a)
+inSafeArray s  = inSafe' undefined s
+
+-- type hack.
+inSafe' :: Variant a => a -> ArgIn (SafeArray a)
+inSafe' b (SA s)  p = writeVarSAFEARRAY p s (fromIntegral (fromEnum (vtEltType b)))
+
+inSAFEARRAY :: ArgIn SAFEARRAY
+inSAFEARRAY s p = writeVarSAFEARRAY p s (fromIntegral (fromEnum VT_VARIANT))
+
+
+resSafeArray :: Variant a => ArgRes (SafeArray a)
+resSafeArray p       = resSafe' undefined p 
+
+resSafe' :: Variant a => a -> ArgRes (SafeArray a)
+resSafe' vt p = do
+	    x <- readVarSAFEARRAY (castPtr p) (fromIntegral (fromEnum (vtEltType vt)))
+	    s <- doThenFree free (readSAFEARRAY True) (castPtr x)
+	    return (SA s)
+
+resSAFEARRAY :: ArgRes SAFEARRAY
+resSAFEARRAY p       = do
+	    x <- readVarSAFEARRAY (castPtr p) (fromIntegral (fromEnum VT_VARIANT))
+	    doThenFree free (readSAFEARRAY True) (castPtr x)
+
+inoutSafeArray  :: (Variant a) => ArgInOut (SafeArray a) (SafeArray a)
+inoutSafeArray d          = (inSafeArray d,resSafeArray)
+outSafeArray :: Variant a => ArgOut (SafeArray a)
+outSafeArray              = inoutSafeArray defaultSafeArray
+
+freeSafeArray :: SafeArray a -> IO ()
+freeSafeArray (SA s) = return () -- it's a foreignObj..
+
+marshallSafeArray :: SafeArray a -> IO (ForeignPtr SAFEARRAY)
+marshallSafeArray (SA s) = marshallSAFEARRAY s
+
+unmarshallSafeArray :: Ptr a -> IO (SafeArray a)
+unmarshallSafeArray x = do
+  s <- unmarshallSAFEARRAY True (castPtr x)
+  return (SA s)
+
+writeSafeArray :: Ptr (SafeArray a) -> SafeArray a -> IO ()
+writeSafeArray ptr (SA s) = writeSAFEARRAY (castPtr ptr) s
+
+readSafeArray :: Variant a => Bool -> Ptr (SafeArray a) -> IO (SafeArray a)
+readSafeArray finaliseMe ptr = readSafeArray' finaliseMe ptr undefined
+
+readSafeArray' :: Variant a => Bool -> Ptr (SafeArray a) -> a -> IO (SafeArray a)
+readSafeArray' finaliseMe ptr x = do
+  xx <- readSA finaliseMe ptr (vtEltType x)
+  return (SA xx)
+
+readSA :: Bool -> Ptr (SafeArray a) -> VARENUM -> IO SAFEARRAY
+readSA finaliseMe ptr vt = do
+  x <- readVarSAFEARRAY (castPtr ptr) (fromIntegral (fromEnum vt))
+  doThenFree free (readSAFEARRAY finaliseMe) (castPtr x)
+
+instance Variant a => Variant (SafeArray a) where
+    inVariant  = inSafeArray
+    resVariant = resSafeArray   
+
+instance Variant SAFEARRAY where
+    inVariant  = inSAFEARRAY
+    resVariant = resSAFEARRAY
+
+\end{code}
+
+\begin{code}
+marshallVariant :: Variant a => a -> IO VARIANT
+marshallVariant v = do
+  x <- allocMemory (fromIntegral sizeofVARIANT)
+  inVariant v (castPtr x)
+  return x
+
+writeVariant :: Variant a => VARIANT -> a -> IO ()
+writeVariant ptr v = inVariant v ptr
+
+readVariant :: Variant a => VARIANT -> IO a
+readVariant ptr = do
+  ptr' <- readPtr ptr
+  resVariant ptr'
+
+unmarshallVariant :: Variant a => VARIANT -> IO a
+unmarshallVariant ptr = resVariant ptr
+
+\end{code}
+
+\end{document}
+ comlib/ClassFactory.lhs view
@@ -0,0 +1,93 @@+
+Haskell implementation of a COM class factory / component instance creator.
+
+\begin{code}
+{-# OPTIONS -#include "ClassFactory_stub.h" #-}
+module ClassFactory 
+	(
+	  createClassFactory -- :: (IID a -> IO (PrimIP a)) -> IO (PrimIP ())
+
+        , iidIClassFactory
+	) where
+
+import Com
+import ComServ hiding ( createInstance )
+import Foreign.Ptr
+import ComException ( cLASS_E_NOAGGREGATION )
+import IOExts
+\end{code}
+
+\begin{code}
+data ClassFactory a
+ = ClassFactory {
+         new_instance :: (IID (IUnknown ()) -> IO (IUnknown ())),
+	 lockCount    :: (IORef Int)
+   }
+
+type IClassFactory a = IUnknown (ClassFactory a)
+
+type This_ClassFactory = Ptr (IClassFactory ())
+
+iidIClassFactory :: IID (IClassFactory ())
+iidIClassFactory = mkIID "{00000001-0000-0000-C000-000000000046}"
+\end{code}
+
+
+Class factory implementation:
+
+\begin{code}
+createInstance :: This_ClassFactory 
+               -> Ptr (IUnknown a)
+	       -> Ptr (IID (IUnknown ()))
+	       -> Ptr (Ptr (IUnknown b))
+	       -> IO HRESULT
+createInstance this punkOuter riid ppv
+ | punkOuter /= nullPtr = return cLASS_E_NOAGGREGATION
+ | otherwise            = do
+    st  <- getObjState this
+    iid <- unmarshallIID False riid
+    unk <- (new_instance st) iid
+    writeIUnknown True ppv unk
+    return s_OK
+
+lockServer :: This_ClassFactory -> Int -> IO HRESULT
+lockServer this ilock = do
+    st    <- getObjState this
+    let ref = lockCount st
+    count <- readIORef ref
+    if lock then
+      writeIORef ref (count+1)
+     else
+      writeIORef ref (count-1)
+    return s_OK
+  where
+   lock 
+    | ilock == 0 = False
+    | otherwise  = True
+
+foreign export stdcall dynamic
+   export_createInstance :: (This_ClassFactory -> Ptr (IUnknown a) -> Ptr (IID (IUnknown ())) -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+
+foreign export stdcall dynamic
+   export_lockServer :: (Ptr (IUnknown a) -> Int -> IO HRESULT) -> IO (Ptr ())
+\end{code}
+
+\begin{code}
+createClassFactory :: (IID (IUnknown ()) -> IO (IUnknown ()))
+		   -> IO (IClassFactory ())
+createClassFactory mkInst = do
+   lcount <- newIORef 0
+   let cf_state = ClassFactory mkInst lcount
+   createComInstance ""
+                     cf_state (return ())
+		     [mkIface iidIClassFactory iClassFactory_vtbl]
+		     iidIClassFactory
+ where
+  guidIClassFactory = iidToGUID iidIClassFactory
+
+iClassFactory_vtbl :: VTable (IClassFactory ()) (ClassFactory ())
+iClassFactory_vtbl = unsafePerformIO $ do
+   addrOf_cI <- export_createInstance createInstance
+   addrOf_lS <- export_lockServer     lockServer
+   createComVTable [addrOf_cI, addrOf_lS]
+\end{code}
+ comlib/Com.lhs view
@@ -0,0 +1,1011 @@+%
+% (c) 1997-2001 Daan Leijen and Sigbjorn Finne
+%
+
+Support library for using and generating client stubs
+for COM objects - closely based on the Com library 
+that ships with HaskellScript.
+
+\begin{code}
+{-# OPTIONS -#include "comPrim.h" -#include "PointerSrc.h" #-}
+module Com 
+    (
+      -- base COM interface, IUnknown:
+      IUnknown_ 	-- abstract, instance of: Eq, Show.
+    , IUnknown		
+    , iidIUnknown	-- :: IID (IUnknown ())
+    
+    , interfaceNULL, isNullInterface, iidNULL
+
+      -- its methods:
+    , queryInterface	-- :: IID (IUnknown b) -> IUnknown a -> IO (IUnknown b)
+    , addRef		-- :: IUnknown a -> IO Word32
+    , release		-- :: IUnknown a -> IO Word32
+
+      -- helpful operators:
+    , ( # )		-- :: a -> (a -> IO b) -> IO b
+    , ( ## )		-- :: IO a -> (a -> IO b) -> IO b
+
+
+      -- setting up and shutting down.
+    , coRun		  -- :: IO a -> IO a
+    , coPerformIO         -- :: IO a -> IO a
+    , coUnsafePerformIO   -- :: IO a -> a
+    , coInitialize	  -- :: IO ()
+    , coUnInitialize	  -- :: IO ()
+    
+      -- GUID API:
+    , GUID		-- abstract, instance of: Eq, Show
+    , mkGUID		-- :: String -> GUID
+    , newGUID           -- :: IO GUID
+    , stringToGUID	-- :: String -> IO GUID
+    , guidToString	-- :: GUID   -> String
+    , nullGUID		-- :: GUID
+
+      -- IID API:
+    , IID		-- abstract, instance of: Eq, Show
+    , mkIID		-- :: String -> IID a
+    , stringToIID	-- :: String -> IO (IID a)
+    , guidToIID		-- :: GUID   -> IID a
+    , iidToGUID		-- :: IID a  -> GUID
+    , castIID           -- :: IID a  -> IID b
+
+      -- CLSID API:
+    , CLSID		 -- abstract, instance of: Eq, Show
+    , mkCLSID		 -- :: String -> CLSID
+    , stringToCLSID	 -- :: String -> IO CLSID
+    , guidToCLSID	 -- :: GUID   -> CLSID
+    , clsidToGUID	 -- :: CLSID  -> GUID
+    , clsidToDisplayName -- :: CLSID  -> String
+
+      -- LIBID
+    , LIBID		-- (a guid)
+    , mkLIBID           -- :: String -> LIBID
+
+      -- HRESULT API:
+    , HRESULT
+    , s_FALSE		-- :: HRESULT
+    , s_OK		-- :: HRESULT
+    , succeeded	        -- :: HRESULT -> Bool
+    , failed	        -- :: HRESULT -> Bool
+    , checkHR		-- :: HRESULT -> IO ()
+    , checkBool		-- :: Int32   -> IO ()
+    , returnHR		-- :: IO ()   -> IO HRESULT
+    , coFailHR		-- :: HRESULT -> IO a
+    , coFailWithHR	-- :: HRESULT -> String  -> IO 
+    , coAssert		-- :: Bool    -> String -> IO ()
+    , coOnFail		-- :: IO a    -> String -> IO a
+    , coFail		-- :: String  -> IO a
+    , isCoError		-- :: IOError -> Bool
+    , coGetErrorHR      -- :: IOError -> HRESULT
+    , coGetErrorString  -- :: IOError -> String
+    , hresultToString   -- :: HRESULT -> IO String
+
+      -- component creation:
+    , coCreateInstance -- :: CLSID -> Maybe (IUnknown b) -> CLSCTX
+		       -- -> IID (IUnknown a) -> IO (IUnknown a)
+    , coCreateObject
+    , coGetObject
+    , coGetActiveObject
+    , coGetFileObject
+    , coCreateInstanceEx
+    , COSERVERINFO(..)
+    , COAUTHIDENTITY(..)
+    , COAUTHINFO(..)
+
+    , withObject   -- :: IUnknown a -> [IUnknown a -> IO b] -> IO [b]
+    , withObject_  -- :: IUnknown a -> [IUnknown a -> IO b] -> IO ()
+    , withMethod   -- :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO [c]
+    , withMethod_  -- :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO ()
+
+
+    , CLSCTX(..)
+
+    , ProgID
+    , progIDFromCLSID     -- :: CLSID  -> IO ProgID
+    , clsidFromProgID     -- :: ProgID -> IO CLSID
+
+    , printMessage
+    , putMessage
+    , messageBox
+    , outputDebugString
+
+    , OSVersionInfo(..)
+    , isWindowsNT          -- :: OSVersionInfo -> Bool
+    , isWindows95          -- :: OSVersionInfo -> Bool
+    , isWindows98          -- :: OSVersionInfo -> Bool
+    , versionInfo	   -- :: OSVersionInfo
+
+    , ifaceToAddr
+    
+      -- IEnum* methods.
+    , enumNext
+    , enumClone
+    , enumReset
+    , enumSkip
+    
+    , BSTR
+    , marshallBSTR
+    , unmarshallBSTR
+    , readBSTR
+    , writeBSTR
+    , freeBSTR
+    , LPSTR
+    
+    , coFree
+    , coAlloc
+    
+    , marshallIUnknown
+    , unmarshallIUnknown
+    , readIUnknown
+    , writeIUnknown
+    
+    , unmarshallIUnknownFO
+    , castIface
+    
+      -- Re-export WideStrings
+    , WideString
+    , marshallWideString
+    , unmarshallWideString
+    , writeWideString
+    , readWideString
+    , sizeofWideString
+    , freeWideString
+    
+      -- marshallers
+    , marshallGUID	-- :: GUID -> IO (ForeignPtr GUID)
+    , unmarshallGUID	-- :: Bool -> Ptr GUID -> IO GUID
+    , writeGUID
+    , readGUID
+    , copyGUID
+    , sizeofGUID
+    
+      -- marshallers
+    , marshallIID	-- :: GUID -> IO (ForeignPtr GUID)
+    , unmarshallIID	-- :: Bool -> Ptr GUID -> IO GUID
+    , writeIID
+    , readIID
+    , sizeofIID
+    , copyIID
+    
+      -- marshallers
+    , marshallCLSID	-- :: CLSID -> IO (ForeignPtr CLSID)
+    , unmarshallCLSID	-- :: Bool -> Ptr CLSID -> IO GUID
+    , writeCLSID
+    , readCLSID
+    , sizeofCLSID
+    , copyCLSID
+    
+    , invokeAndCheck
+    , invokeIt
+    
+    , loadTypeLib
+    , loadTypeLibEx
+    , loadRegTypeLib
+    , queryPathOfRegTypeLib
+    , createTypeLib
+    
+    , LCID
+    
+    , messagePump
+    , postQuitMsg
+    
+    ) where
+
+
+import ComException
+import ComPrim hiding ( coCreateInstance, loadTypeLib, messageBox,
+			loadTypeLibEx, loadRegTypeLib, coCreateInstanceEx
+		      )
+import qualified ComPrim ( coCreateInstance, loadTypeLib, messageBox,
+			   loadTypeLibEx, loadRegTypeLib, coCreateInstanceEx
+			 )
+import HDirect
+import Pointer hiding ( freeBSTR )
+import qualified Pointer as P ( freeBSTR )
+import WideString
+import IOExts   ( unsafePerformIO )
+import Monad    ( when )
+import Foreign  ( deRefStablePtr )
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.Storable
+import Bits
+
+infixl 1 #
+infixl 0 ##
+\end{code}
+
+Operators to provide OO-looking invocation of interface methods, e.g., 
+
+   ip # meth1 args
+
+\begin{code}
+( # )  :: a -> (a -> IO b) -> IO b
+obj # method          = method obj
+
+( ## ) :: IO a -> (a -> IO b) -> IO b
+mObj ## method        = mObj >>= method
+
+\end{code}
+
+IPersistFile - doesn't really belong here..
+
+\begin{code}
+data PersistFile a    = PersistFile
+type IPersistFile a   = IUnknown (PersistFile a)
+
+iidIPersistFile       :: IID (IPersistFile ())
+iidIPersistFile       = mkIID "{0000010B-0000-0000-C000-000000000046}"
+\end{code}
+
+Create instance.
+
+@coCreateInstance@ is the basic COM way of creating components. It takes
+a CLSID, an interface to aggregate on, a process context and an IID to create an object:
+@coCreateInstance clsidAgentServer interfaceNULL LocalProcess iidIAgent@.
+
+\begin{code}
+coCreateInstance :: CLSID 
+		 -> Maybe (IUnknown b)  
+		 -> CLSCTX 
+		 -> IID (IUnknown a) 
+		 -> IO (IUnknown a)
+coCreateInstance clsid inner context iid = do
+  ppvObject <- allocOutPtr
+  clsid     <- marshallCLSID clsid
+  inner     <- marshallInner inner
+  let ctxt   = fromEnum context
+  iid       <- marshallIID iid
+  ComPrim.coCreateInstance (castForeignPtr clsid) inner (fromIntegral ctxt)
+  			   (castForeignPtr iid) ppvObject
+  doThenFree free (readIUnknown False{-finalise only-}) ppvObject
+ where
+  marshallInner Nothing  = return nullFO
+  marshallInner (Just v) = marshallIUnknown v
+
+coCreateInstanceEx :: CLSID 
+		   -> Maybe (IUnknown b)  
+		   -> CLSCTX 
+		   -> Maybe COSERVERINFO
+		   -> IID (IUnknown a) 
+		   -> IO (IUnknown a)
+coCreateInstanceEx clsid pUnkOuter context mbServ iid = do
+  clsid     <- marshallCLSID clsid
+  pUnkOuter <- marshallInner pUnkOuter
+  let ctxt   = fromEnum context
+  iid       <- copyGUID (iidToGUID iid)
+  let mqi = [ MULTI_QI iid nullPtr 0 ]
+  r <- ComPrim.coCreateInstanceEx (castForeignPtr clsid) pUnkOuter (fromIntegral ctxt) mbServ mqi
+  case r of
+    (MULTI_QI iid pItf hr:_) -> do
+      coFree iid
+      checkHR hr
+      unmarshallIUnknown True{-finalise it-} pItf
+    _ -> coFailHR e_FAIL
+ where
+  marshallInner Nothing  = return nullFO
+  marshallInner (Just v) = marshallIUnknown v
+
+
+\end{code}
+
+Create Objects: 
+  prepend @co@ to specify the initial IID, otherwise @iidIDispatch@ is
+  used (see @Automation@ library for more).
+
+@createObject@ creates an object from its progID: @createObject "Agent.Server"@.
+@getObject@ creates an object from its progID and initializes it with a given file:
+@getObject "spreadsheet.exl" "Excel.Application"@. If the filename is empty,
+@getObject@ calls @getActiveObject@.
+@getActiveObject@ tries to connect to an already running instance of the component:
+@getActiveObject "Word.Application"@. 
+@getFileObject@ opens a file or url and loads the associated or persistent object in it:
+@getFileObject "spreadsheet.spd"@. 
+@coCreateInstance@ is the basic com way of creating components. It takes
+a CLSID, process context and IID to create an object: 
+@coCreateInstance clsidAgentServer Nothing LocalProcess iidIAgent@.
+
+\begin{code}
+coCreateObject :: ProgID -> IID (IUnknown a) -> IO (IUnknown a)
+coCreateObject progid iid = do
+    clsid  <- clsidFromProgID progid
+    coCreateInstance clsid Nothing AnyProcess iid
+
+\end{code}
+
+Get Object from File \& ProgID.
+
+\begin{code}
+coGetFileObject :: String -> ProgID -> IID (IUnknown a) -> IO (IUnknown a)
+coGetFileObject ""    progid iid = coGetActiveObject progid iid
+coGetFileObject fname progid iid = do
+    pf <- coCreateObject progid iidIPersistFile
+    stackWideString fname $ \pfname -> do
+      persistfileLoad pf pfname 0
+      pf # queryInterface iid
+
+\end{code}
+
+Get Active Object.
+
+\begin{code}
+coGetActiveObject :: ProgID -> IID (IUnknown a) -> IO (IUnknown a)
+coGetActiveObject progid iid = do
+  clsid   <- clsidFromProgID progid
+  iface   <- primGetActiveObject clsid
+               `coOnFail` ("Could not connect to component '" ++ progid ++ "'")
+  iface # queryInterface iid
+
+primGetActiveObject :: CLSID -> IO (IUnknown a)
+primGetActiveObject clsid = do
+  clsid     <- marshallCLSID clsid
+  ppvObject <- allocOutPtr
+  hr        <- getActiveObject (castForeignPtr clsid) nullPtr ppvObject
+  doThenFree free (readIUnknown False{-finalise only-}) ppvObject
+
+\end{code}
+
+Bind to object via 'moniker string' / display name.
+
+\begin{code}
+coGetObject :: String -> IID (IUnknown a) -> IO (IUnknown a)
+coGetObject fname iid  = do
+   stackWideString fname $ \pfname -> do 
+      iid <- marshallIID iid
+      ppv <- bindObject pfname (castForeignPtr iid)
+      doThenFree free (readIUnknown False{-finalise only-}) ppv
+
+\end{code}
+
+COM initialize/uninitialize:
+
+\begin{code}
+coRun :: IO a -> IO a
+coRun io = do
+  coInitialize
+  v <-
+    catch io
+      (\ err -> do
+        when (isCoError err) (putMessage $ coGetErrorString err)
+        coUnInitialize
+        ioError err)
+  coUnInitialize
+  return v
+
+coPerformIO :: IO a -> IO a
+coPerformIO io =
+ catch io
+       ( \ err -> do 
+	    putMessage (coGetErrorString err)
+            ioError err 
+       )
+
+coUnsafePerformIO :: IO a -> a
+coUnsafePerformIO = unsafePerformIO . coPerformIO
+
+printMessage :: Show a => a -> IO ()
+printMessage x = putMessage (show x)
+
+putMessage :: String -> IO ()
+putMessage msg = 
+	stackString msg               $ \ _ m -> 
+	stackString "Haskell message" $ \ _ t -> 
+	ComPrim.messageBox m t 0x40040
+	  {- To mere mortals, that's MB_OK | MB_ICONINFORMATION | MB_TOPMOST :-) -}
+
+messageBox :: String -> String -> Word32 -> IO ()
+messageBox msg title flg = 
+	stackString msg             $ \ _ m -> 
+	stackString title           $ \ _ t -> 
+	ComPrim.messageBox m t flg
+
+outputDebugString :: String -> IO ()
+outputDebugString msg = primOutputDebugString ("haskell-com: " ++ msg ++ "\n")
+
+{-
+ Really belongs elsewhere...getting info of what kind of
+ platform we're on. 
+-}
+data OSVersionInfo 
+ = OSVersionInfo Word32 Word32 Word32
+
+isWindowsNT :: OSVersionInfo -> Bool
+isWindowsNT (OSVersionInfo _ _ 2{-VER_PLATFORM_WIN32_NT-}) = True
+isWindowsNT _ = False
+
+isWindows95 :: OSVersionInfo -> Bool
+isWindows95 (OSVersionInfo _ 0 1{-VER_PLATFORM_WIN32_WINDOWS-}) = True
+isWindows95 _ = False
+
+isWindows98 :: OSVersionInfo -> Bool
+isWindows98 (OSVersionInfo _ x 1{-VER_PLATFORM_WIN32_WINDOWS-}) = x /= 0
+isWindows98 _ = False
+
+versionInfo :: OSVersionInfo
+versionInfo = unsafePerformIO $ do
+  (j,n,d) <- primGetVersionInfo
+  return (OSVersionInfo j n d)
+
+\end{code}
+
+Enumeration used by @comCreateInstance@ to specify execution
+context in which we'd like to component to be created
+(just use @AnyProcess@ if you're not fussed):
+
+\begin{code}
+data CLSCTX 
+ = CLSCTX_INPROC_SERVER 
+ | CLSCTX_INPROC_HANDLER
+ | CLSCTX_LOCAL_SERVER 
+ | CLSCTX_INPROC_SERVER16
+ | CLSCTX_REMOTE_SERVER
+ | CLSCTX_INPROC_HANDLER16
+ | CLSCTX_INPROC_SERVERX86
+ | CLSCTX_INPROC_HANDLERX86
+ | LocalProcess
+ | InProcess
+ | ServerProcess
+ | AnyProcess
+ deriving (Show)
+
+instance Enum CLSCTX where
+  fromEnum ctx =
+    case ctx of
+     CLSCTX_INPROC_SERVER -> 1
+     CLSCTX_INPROC_HANDLER -> 2
+     CLSCTX_LOCAL_SERVER -> 4
+     CLSCTX_INPROC_SERVER16 -> 8
+     CLSCTX_REMOTE_SERVER -> 16
+     CLSCTX_INPROC_HANDLER16 -> 32
+     CLSCTX_INPROC_SERVERX86 -> 64
+     CLSCTX_INPROC_HANDLERX86 -> 128
+     LocalProcess   -> localProcess
+     InProcess      -> inProcess
+     ServerProcess  -> serverProcess
+     AnyProcess     -> anyProcess
+
+  toEnum x =
+   case x of
+     1    -> CLSCTX_INPROC_SERVER
+     2    -> CLSCTX_INPROC_HANDLER
+     8    -> CLSCTX_INPROC_SERVER16
+     16   -> CLSCTX_REMOTE_SERVER
+     32   -> CLSCTX_INPROC_HANDLER16
+     64   -> CLSCTX_INPROC_SERVERX86
+     128  -> CLSCTX_INPROC_HANDLERX86
+     0x04 -> LocalProcess
+     0x0b -> InProcess
+     0x0d -> ServerProcess
+     4    -> CLSCTX_LOCAL_SERVER
+     _    -> AnyProcess
+
+
+localProcess    :: Int
+localProcess    = 0x04
+inProcess       :: Int
+inProcess       = 0x0b
+serverProcess   :: Int
+serverProcess   = 0x0d
+anyProcess      :: Int
+anyProcess      = 0x0f
+
+\end{code}
+
+VTable method invocation wrappers:
+
+\begin{code}
+invokeAndCheck :: (Ptr any -> Ptr b -> IO HRESULT) -> Int -> IUnknown a -> IO ()
+invokeAndCheck meth offset iptr = do
+  hr <- primInvokeItFO meth offset (marshallIUnknown iptr)
+  checkHR hr
+
+invokeIt :: (Ptr any -> Ptr c -> IO a) -> Int -> IUnknown b -> IO a
+invokeIt meth offset iptr = primInvokeItFO meth offset (marshallIUnknown iptr)
+
+\end{code}
+
+Library provided stubs for IEnum* interfaces - the HaskellDirect
+knows how to generate code for these:
+
+\begin{code}
+enumNext :: Word32 -> (Ptr any -> IO a) -> Word32 -> IUnknown b -> IO [a]
+enumNext szof read_elt celt iptr = do
+    ptr     <- allocBytes (fromIntegral (celt * szof))
+    po      <- allocBytes (fromIntegral sizeofWord32)
+    invokeIt (\ methPtr ip -> primEnumNext methPtr ip celt ptr po) 3 iptr
+    elts_read <- readWord32 (castPtr po)
+    v         <- peek ((castPtr ptr) :: Ptr (Ptr a))
+    unmarshalllist szof 0 elts_read read_elt v
+
+enumSkip :: Word32 -> IUnknown a -> IO ()
+enumSkip count iptr = 
+   invokeIt (\ methPtr ip -> primEnumSkip methPtr ip count) 4 iptr
+
+enumReset :: IUnknown a -> IO ()
+enumReset iptr =
+   invokeIt (\ methPtr ip -> primEnumReset methPtr ip) 5 iptr
+
+enumClone :: IUnknown a -> IO (IUnknown b)
+enumClone iptr = do
+   ppv     <- allocOutPtr
+   invokeIt (\ methPtr ip -> primEnumClone methPtr ip ppv) 6 iptr
+   doThenFree free (readIUnknown False{-finalise only-}) ppv
+\end{code}
+
+BSTRs were introduced by Automation, but their now used in non-Auto
+contexts.
+
+\begin{code}
+data BSTR = BSTR
+
+writeBSTR :: Ptr String -> String -> IO ()
+writeBSTR ptr str =
+  stackString str $ \_ pstr -> do
+    o_stringToBSTR <- prim_ComPrim_stringToBSTR (castPtr pstr) ptr
+    checkHR o_stringToBSTR
+
+--readBSTR :: Ptr BSTR -> IO String
+readBSTR :: Ptr (Ptr String) -> IO String
+readBSTR ptr = do
+  ptr' <- peek ptr
+  unmarshallBSTR ptr'
+
+unmarshallBSTR :: Ptr String -> IO String
+unmarshallBSTR bstr 
+  | bstr == nullPtr = return ""
+  | len == 0  = return ""
+  | otherwise = do
+     stackStringLen (4 + fromIntegral len) "" $ \ pstr -> do
+     bstrToStringLen (castPtr bstr) len (castPtr pstr)
+     unmarshallString pstr
+ where
+   len  = bstrLen (castPtr bstr)
+
+marshallBSTR :: String -> IO (Ptr String)
+marshallBSTR s = 
+  stackString s $ \ _ pstr -> do
+  ptr <- stringToBSTR (castPtr pstr)
+  x   <- peek (castPtr ptr)
+  free ptr
+  return x
+
+freeBSTR x 
+ | x == nullPtr = return ()
+ | otherwise    = P.freeBSTR x
+
+-- This type sometimes appear in IDL and tlbs, so
+-- to avoid having to depend on wtypes for it, let's
+-- simply define it here.
+type LPSTR = String
+
+coFree :: Ptr a -> IO ()
+coFree p = freeMemory p
+
+coAlloc :: Word32 -> IO (Ptr a)
+coAlloc sz = allocMemory sz
+\end{code}
+
+\begin{code}
+type ProgID = String
+
+clsidFromProgID :: ProgID -> IO CLSID
+clsidFromProgID progid =
+   stackString progid $ \ _ pprogid -> do
+     pclsid  <- coAlloc sizeofCLSID
+     coOnFail (primCLSIDFromProgID pprogid (castPtr pclsid))
+     	      ("Component '" ++ progid ++ "' is unknown")
+     unmarshallCLSID True pclsid
+
+progIDFromCLSID :: CLSID -> IO ProgID
+progIDFromCLSID clsid = do
+   pclsid    <- marshallCLSID clsid
+   pwide     <- primProgIDFromCLSID (castForeignPtr pclsid)
+   (pstr,hr) <- wideToString (castPtr pwide)
+   checkHR hr
+   str       <- unmarshallString (castPtr pstr)
+   coFree pstr
+   coFree pwide
+   return str
+
+\end{code}
+
+Type libraries are identified by a GUID too:
+
+\begin{code}
+type LIBID = GUID
+
+mkLIBID :: String -> LIBID
+mkLIBID = mkGUID
+
+type LCID = Word32
+\end{code}
+
+
+<sect>Representing interface pointers
+<p>
+
+To represent a (COM) interface pointer, we use the type <tt/IUnknown/,
+which is parameterised over its interface:
+
+\begin{code}
+iidIUnknown :: IID (IUnknown ())
+iidIUnknown = mkIID "{00000000-0000-0000-C000-000000000046}"
+\end{code}
+
+Equality of interface pointers is defined by the COM spec
+as being equality of IUnknown (pointers to) implementations.
+
+\begin{code}
+instance Eq (IUnknown_ a) where
+   iface1 == iface2    = coEqual (castIface iface1) (castIface iface2)
+
+castIface :: IUnknown a -> IUnknown b
+castIface (Unknown o) = Unknown o
+
+interfaceNULL :: IUnknown a
+interfaceNULL = unsafePerformIO (unmarshallIUnknown False nullPtr)
+
+isNullInterface :: IUnknown a -> Bool
+isNullInterface (Unknown fo)    = foreignPtrToPtr fo == nullPtr
+
+iidNULL :: IID ()
+iidNULL = mkIID "{00000000-0000-0000-0000-000000000000}"
+
+instance Show (IUnknown_ a) where
+  showsPrec _ iface   = 
+    shows "<interface pointer = " . 
+    shows (ifaceToAddr iface)     .
+    shows ">"
+
+\end{code}
+
+Library provided stubs for IUnknown's methods:
+(derived from H/Direct output)
+
+\begin{code}
+queryInterface :: IID (IUnknown b) -> IUnknown a -> IO (IUnknown b)
+queryInterface riid iptr = do
+    ppvObject <- allocOutPtr
+    priid     <- marshallIID riid
+    invokeIt (\ methPtr ip -> primQI methPtr ip (castForeignPtr priid) ppvObject) 0 iptr
+    doThenFree free (readIUnknown False{-finalise only-}) ppvObject
+
+addRef :: IUnknown a -> IO Word32
+addRef iptr = invokeIt (\ methPtr ip -> primAddRef methPtr ip) 1 iptr
+
+release :: IUnknown a -> IO Word32
+release iptr = invokeIt (\ methPtr ip -> primRelease methPtr ip) 2 iptr
+
+\end{code}
+
+HDirect generated stub needed by @coGetObject@:
+
+\begin{code}
+persistfileLoad :: IPersistFile a -> Ptr Wchar_t -> Word32 -> IO ()
+persistfileLoad iptr pszFileName dwMode =
+    invokeIt (\ methPtr ip -> primPersistLoad methPtr ip pszFileName dwMode) 5 iptr
+\end{code}
+
+GUIDs:
+
+\begin{code}
+newtype GUID     = GUID (ForeignPtr ()) --(Pointer Guid)
+
+data Guid	 = Guid
+
+mkGUID :: String -> GUID
+mkGUID str = unsafePerformIO (stringToGUID str)
+
+newGUID :: IO GUID
+newGUID = do
+  pg  <- coAlloc sizeofGUID
+  ng  <- makeFO pg (castPtrToFunPtr finalFreeMemory)
+  primNewGUID ng
+  return (GUID ng)
+
+nullGUID :: GUID
+nullGUID = unsafePerformIO $ do
+  x <- primNullIID
+  p <- makeFO x (castPtrToFunPtr finalNoFree) --primNoFree
+  return (GUID p)
+
+marshallGUID :: GUID -> IO (ForeignPtr GUID)
+marshallGUID (GUID ptr) = return (castForeignPtr ptr)
+
+{-
+ A version of the GUID marshaller which copies rather
+ than hands back a pointer to the (immutable) GUID.
+-}
+copyGUID :: GUID -> IO (Ptr ())
+copyGUID (GUID ptr) = do
+    pg  <- coAlloc sizeofGUID
+    primCopyGUID ptr pg
+    return pg
+
+unmarshallGUID :: Bool -> Ptr GUID -> IO GUID
+unmarshallGUID finaliseMe ptr = do
+     -- ToDo: verify that HDirect *never ever* allocates and
+     --       stores a GUID in malloc()-space, but consistently
+     --       uses the COM task allocator. (Why? because the
+     --       finalizer below will tell the COM task allocator
+     --       to free the GUID once done with it)
+   f  <- makeFO ptr (castPtrToFunPtr $ if finaliseMe then finalFreeMemory else finalNoFree)
+   return (GUID f)
+
+writeGUID :: Ptr GUID -> GUID -> IO ()
+writeGUID ptr (GUID g) = poke (castPtr ptr) (foreignPtrToPtr g)
+
+readGUID :: Bool -> Ptr GUID -> IO GUID
+readGUID finaliseMe ptr = do
+--  ptr  <- peek ptr
+  unmarshallGUID finaliseMe ptr
+
+sizeofGUID  :: Word32
+sizeofGUID  = 16
+
+stringToGUID :: String -> IO GUID
+stringToGUID str =
+   stackWideString str $ \xstr -> do
+   pg <- coAlloc sizeofGUID
+   primStringToGUID xstr (castPtr pg)
+   unmarshallGUID True pg
+
+stringFromGUID :: GUID -> IO String
+stringFromGUID guid = do
+   pguid     <- marshallGUID guid
+   pwide     <- primGUIDToString (castForeignPtr pguid)
+   (pstr,hr) <- wideToString (castPtr pwide)
+   checkHR hr
+   str       <- unmarshallString (castPtr pstr)
+   coFree pstr
+   coFree pwide
+   return str
+
+guidToString :: GUID -> String
+guidToString ptr = unsafePerformIO (stringFromGUID ptr)
+\end{code}
+
+Give the interface identifier(IID) a type parameter, so that when
+we come to define the Haskell type of <tt/IUnknown.QueryInterface(),/
+we can use the type checker to ensure that the IID passed to 
+<tt/QueryInterface/ agrees with the interface at which we're using
+the interface pointer that's returned (Hmm..this'll hopefully all become
+clearer.)
+
+\begin{code}
+newtype IID a	= IID GUID   deriving ( Eq )
+newtype CLSID	= CLSID GUID deriving ( Eq )
+
+mkIID   :: String -> IID a
+mkIID str   = IID (mkGUID str)
+
+mkCLSID :: String -> CLSID
+mkCLSID str = CLSID (mkGUID str)
+
+-- no need to provide marshallers for these, the IDL compiler
+-- knows that they're both represented by GUIDs.
+
+stringToIID :: String -> IID a
+stringToIID str = mkIID str
+
+stringToCLSID :: String -> CLSID
+stringToCLSID str = mkCLSID str
+
+iidToString :: IID a -> String
+iidToString (IID i) = guidToString i
+
+clsidToString :: CLSID -> String
+clsidToString (CLSID clsid) = guidToString clsid
+
+iidToGUID :: IID a -> GUID
+iidToGUID (IID g) = g
+
+castIID :: IID a -> IID b
+castIID (IID i) = IID i
+
+clsidToGUID :: CLSID -> GUID
+clsidToGUID (CLSID g) = g
+
+clsidToDisplayName :: CLSID  -> String
+clsidToDisplayName (CLSID g) = "clsid:" ++ tail (init (show g))
+
+guidToIID :: GUID -> IID a
+guidToIID g = IID g
+
+guidToCLSID :: GUID -> CLSID
+guidToCLSID g = CLSID g
+
+instance Show (IID a) where
+  showsPrec _ (IID i)  = showString (guidToString i)
+
+instance Show CLSID where
+  showsPrec _ (CLSID c)  = showString (guidToString c)
+
+instance Show GUID where
+  showsPrec _ guid     = showString (guidToString guid)
+
+instance Eq GUID where
+  (GUID x) == (GUID y) = unsafePerformIO $ do
+     return (isEqualGUID x y)
+
+marshallIID :: IID a -> IO (ForeignPtr (IID a))
+marshallIID (IID x) = marshallGUID x >>= return.castForeignPtr
+unmarshallIID :: Bool -> Ptr (IID a) -> IO (IID a)
+unmarshallIID finaliseMe x = do
+  i <- unmarshallGUID finaliseMe (castPtr x)
+  return (IID i)
+
+copyIID (IID x) = copyGUID x
+
+readIID :: Bool -> Ptr (Ptr (IID a)) -> IO (IID a)
+readIID finaliseMe ptr = do
+  a  <- peek ptr
+  unmarshallIID finaliseMe (castPtr a)
+
+writeIID :: Ptr (IID a) -> IID a -> IO ()
+writeIID ptr (IID i) = writeGUID (castPtr ptr) i
+
+--------
+
+marshallCLSID (CLSID x) = marshallGUID x
+
+unmarshallCLSID :: Bool -> Ptr CLSID -> IO CLSID
+unmarshallCLSID finaliseMe x = do
+  i <- unmarshallGUID finaliseMe (castPtr x)
+  return (CLSID i)
+
+copyCLSID (CLSID x) = copyGUID x
+
+readCLSID :: Bool -> Ptr (Ptr CLSID) -> IO CLSID
+readCLSID finaliseMe ptr = do
+  a  <- peek ptr
+  unmarshallCLSID finaliseMe (castPtr a)
+
+writeCLSID :: Ptr CLSID -> CLSID -> IO ()
+writeCLSID ptr (CLSID i) = writeGUID (castPtr ptr) i
+
+sizeofCLSID = sizeofGUID
+\end{code}
+
+\begin{code}
+coInitialize :: IO ()
+coInitialize = comInitialize
+
+coUnInitialize :: IO ()
+coUnInitialize = comUnInitialize
+
+sizeofIID = sizeofGUID
+\end{code}
+
+\begin{code}
+coEqual :: IUnknown a -> IUnknown b -> Bool
+coEqual ip1 ip2 = unsafePerformIO $ primComEqual (castIface ip1) (castIface ip2)
+\end{code}
+
+Interface pointer marshallers:
+
+\begin{code}
+-- marshallIUnknown is in ComPrim.idl
+
+unmarshallIUnknown :: Bool -> Ptr b -> IO (IUnknown a)
+unmarshallIUnknown finaliseMe x = do
+   ip <- addrToIPointer finaliseMe x
+   case finaliseMe of
+     True | x /= nullPtr -> ip # addRef >> return ip
+     _    -> return ip
+
+unmarshallIUnknownFO :: ForeignPtr b -> IO (IUnknown a)
+unmarshallIUnknownFO i = return (Unknown (castForeignPtr i))
+  -- ToDo: I believe it is correct never to do an AddRef()
+  --       here, but double-check the spec.
+
+{-
+  addRefMe == True  => attach finaliser (which calls Release()), and
+  		       call addRef on i-pointer before returning.
+           == False => attach finaliser (which calls Release()) only.
+
+  The former case is used when you receive an i-pointer from the outside
+  world and want to copy a reference to it into the Haskell heap. This
+  does not include i-pointers you receive via [out] pointers when calling
+  a COM component method from Haskell, where it is the obligation of the
+  server filling in the [out] pointer to call addRef() for you.
+-}
+readIUnknown :: Bool -> Ptr b -> IO (IUnknown a)
+readIUnknown addRefMe x = do
+  ptr <- peek (castPtr x)
+  ip <- addrToIPointer True ptr
+  case addRefMe of
+     True | x /= nullPtr -> ip # addRef >> return ip
+     _    -> return ip
+
+writeIUnknown :: Bool -> Ptr (Ptr (IUnknown b)) -> IUnknown a -> IO ()
+writeIUnknown addRefMe x v = do
+   let a = ifaceToAddr v
+   when (addRefMe && a /= nullPtr)
+        (v # addRef >> return ())
+   writePtr x a
+\end{code}
+
+
+@withObject@ applies every method in a list to an 
+object: @withObject genie [showUp, speak "hi", hide]@.
+@withMethod@ applies every argument in a list to a
+method: @genie # withMethod speak ["hello", "world"]@.
+
+\begin{code}
+withObject_ :: IUnknown a -> [IUnknown a -> IO b] -> IO ()
+withObject_ obj       = sequence_ .  map ( obj # ) 
+
+withMethod_ :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO ()
+withMethod_ method args obj = sequence_ $ map (\x -> obj # method x) args
+
+withObject :: IUnknown a -> [IUnknown a -> IO b] -> IO [b]
+withObject obj        = sequence . map ( obj # )
+
+withMethod :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO [c]
+withMethod method args obj = sequence $ map (\x -> obj # method x) args
+\end{code}
+
+\begin{code}
+loadTypeLib :: String -> IO (IUnknown a)
+loadTypeLib fname = do
+    ptr <- allocOutPtr
+    stackWideString fname $ \pfname -> do
+      ComPrim.loadTypeLib pfname ptr
+      doThenFree free (readIUnknown False{-finalise only-}) ptr
+
+loadRegTypeLib :: GUID -> Int -> Int -> Int -> IO (IUnknown a)
+loadRegTypeLib guid maj min lcid = do
+    ptr     <- allocOutPtr
+    p_guid  <- marshallGUID guid
+    ComPrim.loadRegTypeLib (castForeignPtr p_guid)
+    			   (fromIntegral maj) (fromIntegral min)
+			   (fromIntegral lcid) ptr
+    doThenFree free (readIUnknown False{-finalise only-}) ptr
+
+queryPathOfRegTypeLib :: GUID
+		      -> Word16
+		      -> Word16
+		      -> IO String
+queryPathOfRegTypeLib gd maj min = do
+    pgd   <- marshallGUID gd
+    pbstr <- primQueryPathOfRegTypeLib (castForeignPtr pgd) maj min
+    if nullPtr == pbstr then
+        return ""
+      else do
+        str <- unmarshallBSTR (castPtr pbstr)
+	freeBSTR pbstr
+	return str
+
+\end{code}
+
+\begin{code}
+createTypeLib :: String -> IO (IUnknown a) --(ICreateTypeLib a)
+createTypeLib nm = do
+   wstr <- stringToWide nm
+   pptr <- primCreateTypeLib 1{-SYS_WIN32-} wstr
+   doThenFree free (readIUnknown False{-finalise only-}) pptr
+
+\end{code}
+
+\begin{code}
+loadTypeLibEx :: String -> Bool -> IO (IUnknown a)
+loadTypeLibEx path reg_tlb = do
+    let
+      {-
+        This Int is used to map onto the following enum
+
+         typedef enum tagREGKIND { REGKIND_DEFAULT, REGKIND_REGISTER, REGKIND_NONE };
+      -}
+     rkind :: Int
+     rkind
+      | reg_tlb   = 1
+      | otherwise = 2
+
+    out_ptr <- allocOutPtr
+    stackWideString path $ \pfname -> do
+      ComPrim.loadTypeLibEx pfname (fromIntegral rkind) out_ptr
+      doThenFree free (readIUnknown False{-finalise only-}) out_ptr
+
+\end{code}
+ comlib/ComDll.lhs view
@@ -0,0 +1,321 @@+
+Support for sealing up Haskell code as an in-proc COM server.
+
+The export list is odd in that it doesn't export the Haskell functions 
+required to implement the class factory, but rather an action which
+exposes them via a COM-like interface.
+
+\begin{code}
+{-# OPTIONS -#include "ComDll_stub.h" -#include <windows.h> -#include "Registry.h" #-}
+module ComDll
+	(  
+	   ComponentInfo(..)
+	,  mkComponentInfo
+	,  withComponentName
+	,  withProgID
+	,  withVerIndepProgID
+	,  onRegister
+	,  onFinalize
+	,  hasTypeLib
+
+	,  createIComDll   -- :: Ptr (){-HMODULE-} -> [ComponentInfo] -> IO
+
+	,  regAddEntry
+	,  regRemoveEntry
+	,  RegHive(..)
+	
+	,  stdRegComponent
+	,  stdUnRegComponent
+	) where
+
+import ClassFactory
+import Com
+import ComException
+import ComServ
+import ComPrim ( getModuleFileName )
+import HDirect ( Ptr, marshallString )
+
+import Foreign  hiding ( Ptr )
+import Word ( Word32 )
+import HDirect ( marshallMaybe )
+import IOExts
+
+import Monad
+import List  ( find )
+
+\end{code}
+
+The information an implementation of a Haskell COM component
+needs to supply in order to hook into the machinery provided
+here for interfacing to how COM does activation for in-proc
+components:
+
+\begin{code}
+data ComponentInfo
+  = ComponentInfo
+      { newInstance       :: String -> IO () -> IID (IUnknown ()) -> IO (IUnknown ())
+      , componentFinalise :: IO ()
+      , componentName     :: String
+      , componentProgID   :: String
+      , componentVProgID  :: String
+      , componentTLB      :: Bool
+      , registerComponent :: ComponentInfo -> String -> Bool -> IO ()
+      , componentCLSID    :: CLSID
+      }
+
+withProgID :: String -> ComponentInfo -> ComponentInfo
+withProgID p info = info{componentProgID=p}
+
+onRegister :: (ComponentInfo -> String -> Bool -> IO ()) -> ComponentInfo -> ComponentInfo
+onRegister reg info = 
+  info{registerComponent= \ a b c -> reg a b c >> (registerComponent info) a b c}
+
+onFinalize :: IO () -> ComponentInfo -> ComponentInfo
+onFinalize act info = info{componentFinalise= act >> (componentFinalise info)}
+
+withVerIndepProgID :: String -> ComponentInfo -> ComponentInfo
+withVerIndepProgID p info = info{componentVProgID=p}
+
+withFinaliser :: IO () -> ComponentInfo -> ComponentInfo
+withFinaliser act info = info{componentFinalise=act}
+
+withComponentName :: String -> ComponentInfo -> ComponentInfo
+withComponentName n info = info{componentName=n}
+
+hasTypeLib :: ComponentInfo -> ComponentInfo
+hasTypeLib info = info{componentTLB=True}
+
+ -- constructor used to lessen the reliance on concrete rep.
+mkComponentInfo :: CLSID
+		-> (String -> Bool -> IO ())
+		-> (String -> IO () -> IID (IUnknown ()) -> IO (IUnknown ()))
+		-> ComponentInfo
+mkComponentInfo cls reg n = ComponentInfo n (return ()) "" "" "" False (\ _ -> reg) cls
+\end{code}
+
+The state maintained by each instance of a 'ComDll' wrapper:
+
+\begin{code}
+data ComDllState
+  = ComDllState {
+      dllPath    :: String,
+      components :: IORef [ComponentInfo],
+      lockCount  :: IORef Int
+     }
+\end{code}
+
+
+\begin{code}
+dllGetClassObject :: ComDllState -> Ptr CLSID -> Ptr (IID a) -> Ptr (Ptr (IUnknown a)) -> IO HRESULT
+dllGetClassObject comDll rclsid riid ppvObject = do
+  iid <- unmarshallIID False (castPtr riid)
+  let g = iidToGUID iid
+  if ( not (g == iidToGUID iidIClassFactory || g == iidToGUID iidIUnknown) ) then
+     return e_NOINTERFACE
+   else do
+    clsid <- unmarshallCLSID False rclsid
+    cs    <- readIORef (components comDll)
+    case lookupCLSID clsid cs of
+      Nothing -> return cLASS_E_CLASSNOTAVAILABLE
+      Just i  -> do
+         ip <- createClassFactory (newInstance i (dllPath comDll) (componentFinalise i))
+	 writeIUnknown False ppvObject ip
+	 return s_OK
+
+lookupCLSID :: CLSID -> [ComponentInfo] -> Maybe ComponentInfo
+lookupCLSID clsid cs = find (\ x -> clsidToGUID (componentCLSID x) == guid) cs
+ where
+  guid = clsidToGUID clsid
+
+dllCanUnloadNow :: ComDllState -> IO HRESULT
+dllCanUnloadNow state = do
+   c <- readIORef (lockCount state)
+   if c == 0 then 
+     return s_OK
+    else
+     return s_FALSE
+
+dllRegisterServer :: ComDllState -> IO HRESULT
+dllRegisterServer = registerServer True
+
+dllUnregisterServer :: ComDllState -> IO HRESULT
+dllUnregisterServer = registerServer False
+
+registerServer :: Bool -> ComDllState -> IO HRESULT
+registerServer isReg st = do
+  cs   <- readIORef (components st)
+  let
+   path = dllPath st
+   regComponent info
+     | not isReg = do
+	 -- give the user-supplied un-reg action the opportunity
+	 -- to delete some entries first.
+       (registerComponent info) info path isReg
+       stdUnRegComponent info True path
+     | otherwise = do
+       stdRegComponent info True path
+       (registerComponent info) info path isReg
+
+
+  mapM_ regComponent cs
+  case s_OK of
+    14 -> return s_OK
+    x  -> return x
+
+dllUnload :: ComDllState -> IO ()
+dllUnload st = return ()
+
+\end{code}
+
+Creating + manipulating the state of a Haskell DLL containing
+Haskell COM server(s).
+
+\begin{code}
+newComDllState :: Ptr (){-HANDLE-} -> [ComponentInfo] -> IO ComDllState
+newComDllState hMod cs = do
+  path   <- getModuleFileName hMod
+  ref_cs <- newIORef cs
+    -- The lock count is intended used by DllCanUnloadNow() to keep
+    -- track of when the Com DLL can safely be unloaded. It is only
+    -- safe to do so if no COM interface pointers handed out by the 
+    -- component are currently alive.
+    --
+    -- The Com library doesn't yet try to keep track of this, so the
+    -- lock count is always left at 1 (==> DllCanUnloadNow() always returns
+    -- S_FALSE.)
+  lc     <- newIORef 1
+  return (ComDllState path ref_cs lc)
+\end{code}
+
+\begin{code}
+createIComDll :: Ptr (){-HMODULE-} -> [ComponentInfo] -> IO (VTable iid_comDllState ComDllState)
+createIComDll hMod components = do
+   state       <- newComDllState hMod components
+   meths       <- iComDllEntryPoints state
+   createVTable meths
+
+iComDllEntryPoints :: ComDllState -> IO [Ptr ()]
+iComDllEntryPoints state = do
+  addrOf_DllUnload	     <- export_DllUnload   (dllUnload state)
+  addrOf_DllCanUnloadNow     <- export_nullaryMeth (dllCanUnloadNow state)
+  addrOf_DllRegisterServer   <- export_nullaryMeth (dllRegisterServer state)
+  addrOf_DllUnregisterServer <- export_nullaryMeth (dllUnregisterServer state)
+  addrOf_DllGetClassObject   <- export_dllGetClassObject (dllGetClassObject state)
+  return [ addrOf_DllUnload
+         , addrOf_DllCanUnloadNow
+	 , addrOf_DllRegisterServer
+	 , addrOf_DllUnregisterServer
+	 , addrOf_DllGetClassObject
+	 ]
+
+foreign export ccall dynamic
+   export_DllUnload :: (IO ()) -> IO (Ptr ())
+foreign export ccall dynamic 
+   export_nullaryMeth :: (IO HRESULT) -> IO (Ptr ())
+
+foreign export ccall dynamic
+   export_dllGetClassObject :: (Ptr CLSID -> Ptr (IID a) -> Ptr (Ptr (IUnknown a)) -> IO HRESULT) -> IO (Ptr ())
+
+\end{code}
+
+\begin{code}
+data RegHive
+ = HKEY_CLASSES_ROOT
+ | HKEY_CURRENT_USER
+ | HKEY_LOCAL_MACHINE
+ | HKEY_USERS
+ | HKEY_CURRENT_CONFIG
+   deriving ( Eq, Ord, Enum )
+
+regAddEntry :: RegHive
+	    -> String
+	    -> Maybe String
+	    -> IO ()
+regAddEntry hive path value = do
+   m_path  <- marshallString path
+   m_value <- marshallMaybe marshallString nullPtr value
+   hr      <- primRegAddEntry (fromEnum hive) m_path m_value
+   checkHR hr
+
+regRemoveEntry :: RegHive
+	       -> String
+	       -> String
+	       -> Bool
+	       -> IO ()
+regRemoveEntry hive path value removeKey = do
+   m_path  <- marshallString path
+   m_value <- marshallString value
+   let m_removeKey
+        | removeKey = (1::Int)
+        | otherwise = 0
+   hr      <- primRegRemoveEntry (fromEnum hive) m_path m_value m_removeKey
+   checkHR hr
+
+foreign import ccall "primRegAddEntry" 
+   primRegAddEntry :: Int -> Ptr String -> Ptr String -> IO HRESULT
+foreign import ccall "primRegRemoveEntry" 
+   primRegRemoveEntry :: Int -> Ptr String -> Ptr String -> Int -> IO HRESULT
+
+\end{code}
+
+\begin{code}
+stdRegComponent :: ComponentInfo -> Bool -> String -> IO ()
+stdRegComponent info isInProc path = do
+   let clsid_path = "CLSID\\" ++ clsid_str
+       progid     = componentProgID info
+       vprogid    = componentVProgID info
+       clsid_str  = show (componentCLSID info)
+
+        -- Add CLSID\{clsid}\friendly name
+   regAddEntry HKEY_CLASSES_ROOT clsid_path (Just (componentName info))
+        -- Add CLSID\{clsid}\ProgID (if any.)
+   when (not (null progid)) (regAddEntry HKEY_CLASSES_ROOT (clsid_path++"\\ProgID") (Just progid))
+        -- Add CLSID\{clsid}\VersionIndependentProgID (if any.)
+   when (not (null vprogid)) (regAddEntry HKEY_CLASSES_ROOT (clsid_path++"\\VersionIndependentProgID") (Just vprogid))
+        -- Add CLSID\{clsid}\{Inproc,Local}Server32\path
+   regAddEntry HKEY_CLASSES_ROOT (clsid_path ++ (if isInProc then "\\InprocServer32" else "\\LocalServer32")) (Just path)
+
+      -- register the type library; we don't care if it fails, or not.
+   when (componentTLB info)
+        (catch (loadTypeLibEx path True{-register-} >>= \ p -> p # release >> return ())
+	       (\ _ -> return ()))
+
+	-- Add the ProgID entries
+
+   when (not (null progid))  (regAddEntry HKEY_CLASSES_ROOT (progid  ++ "\\CLSID") (Just clsid_str))
+   when (not (null vprogid)) (regAddEntry HKEY_CLASSES_ROOT (vprogid ++ "\\CLSID") (Just clsid_str))
+   when (not (null vprogid) && not (null progid))
+                             (regAddEntry HKEY_CLASSES_ROOT (progid ++ "\\CurVer") (Just vprogid))
+   return ()
+
+\end{code}
+
+The removal of entries isn't quite right
+
+\begin{code}
+stdUnRegComponent :: ComponentInfo -> Bool -> String -> IO ()
+stdUnRegComponent info isInProc path = do
+   let clsid_path = "CLSID\\" ++ clsid_str
+       progid     = componentProgID info
+       vprogid    = componentVProgID info
+       clsid_str  = show (componentCLSID info)
+
+        -- Remove CLSID\{clsid}\{Local,Inproc}Server32
+   regRemoveEntry HKEY_CLASSES_ROOT clsid_path (if isInProc then "InprocServer32" else "LocalServer32") True
+        -- Remove CLSID\{clsid}\VersionIndependentProgID (if any.)
+   when (not (null vprogid)) (regRemoveEntry HKEY_CLASSES_ROOT clsid_path "VersionIndependentProgID" True)
+        -- Remove CLSID\{clsid}\ProgID (if any.)
+   when (not (null progid)) (regRemoveEntry HKEY_CLASSES_ROOT clsid_path "ProgID" True)
+        -- Remove CLSID\{clsid}\friendly name
+   regRemoveEntry HKEY_CLASSES_ROOT "CLSID" clsid_str True
+
+	-- Remove the ProgID entries
+   when (not (null progid))  (regRemoveEntry HKEY_CLASSES_ROOT (progid  ++ "\\CLSID") clsid_str False)
+   when (not (null progid))  (regRemoveEntry HKEY_CLASSES_ROOT progid  "CLSID"  True)
+   when (not (null progid) && not (null vprogid)) 
+			     (regRemoveEntry HKEY_CLASSES_ROOT  progid "CurVer" True)
+   when (not (null vprogid)) (regRemoveEntry HKEY_CLASSES_ROOT (vprogid ++ "\\CLSID") clsid_str False)
+   when (not (null vprogid)) (regRemoveEntry HKEY_CLASSES_ROOT vprogid  "CLSID" True)
+   return ()
+
+\end{code}
+ comlib/ComException.lhs view
@@ -0,0 +1,802 @@+%
+% (c) - sof 1999.
+%
+
+'Com exception handling' / HRESULT manipulation in
+Haskell.
+
+\begin{code}
+{-# OPTIONS -#include "comPrim.h" #-}
+module ComException where
+
+import HDirect hiding ( readFloat )
+import ComPrim
+import Int
+import Word
+import Bits
+{- BEGIN_GHC_ONLY
+import GHC.IOBase
+import Dynamic
+import Maybe ( isJust )
+   END_GHC_ONLY -}
+import NumExts
+import IO
+import qualified Control.Exception ( catch, ioErrors )
+\end{code}
+
+\begin{code}
+check2HR :: HRESULT -> IO ()
+check2HR hr
+      | succeeded hr = return ()
+      | otherwise    = do
+	  dw <- getLastError
+	  coFailHR (word32ToInt32 dw)
+
+{- FALSE = 0, TRUE = -1 -}
+checkBool :: Int32 -> IO ()
+checkBool flg
+      | flg /=0      = return ()
+      | otherwise    = do
+	  dw <- getLastError
+	  coFailHR (word32ToInt32 dw)
+
+returnHR :: IO () -> IO HRESULT
+returnHR act = (do
+  act 
+  return s_OK)
+{- BEGIN_GHC_ONLY 
+    `Control.Exception.catch`
+      (\ ex -> 
+        case Control.Exception.ioErrors ex of
+	  Just i -> 
+	    case coGetErrorHR i of
+	      Just x  -> return x
+	      Nothing -> return failure
+	  Nothing -> return failure)
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+     -- once we can assume that IOError == Exception on the
+     -- Hugs side, no need for this.
+    `IO.catch`
+    (\ ex -> 
+        case coGetErrorHR ex of
+	  Just x  -> return x
+	  Nothing -> return failure)
+{- END_NOT_FOR_GHC -}
+ where
+   -- better return codes could easily be imagined..
+  failure = e_FAIL
+
+isCoError        :: IOError -> Bool
+coGetErrorHR     :: IOError -> Maybe HRESULT
+coGetErrorString :: IOError -> String
+
+{- BEGIN_GHC_ONLY
+isCoError ioe = isJust (coGetErrorHR ioe)
+
+#if __GLASGOW_HASKELL__ >= 505
+coGetErrorHR (IOError _ (DynIOError d) _ _ _) = 
+#else
+coGetErrorHR (IOException (IOError _ (DynIOError d) _ _ _)) = 
+#endif
+  case fromDynamic d of
+    Just (ComError hr) -> Just hr
+    Nothing            -> Nothing
+coGetErrorHR _	= Nothing
+
+#if __GLASGOW_HASKELL__ >= 505
+coGetErrorString ioe@(IOError _ (DynIOError dyn) loc str _)
+#else
+coGetErrorString ioe@(IOException (IOError _ (DynIOError dyn) loc str _))
+#endif
+  = case (fromDynamic dyn) of
+       Just (ComError hr) -> str ++ showParen True (showHex (int32ToWord32 hr)) ""
+       Nothing            -> ioeGetErrorString ioe
+coGetErrorString ioe = ioeGetErrorString ioe
+   END_GHC_ONLY -}
+
+{- BEGIN_NOT_FOR_GHC -}
+
+userPrefix = "User error: "
+prefixLen  = length userPrefix + length coPrefix
+
+isCoError err         = (isUserError err)  &&
+                        (prefix == userPrefix ++ coPrefix)
+                      where
+                        prefix    = take prefixLen (ioeGetErrorString err)
+
+--ToDo: try to fish it out from the user string.
+coGetErrorHR _ = Nothing
+
+coGetErrorString e
+  | isCoError e    = drop prefixLen (ioeGetErrorString e)
+  | otherwise      = drop (length userPrefix) (ioeGetErrorString e)
+
+{- END_NOT_FOR_GHC -}
+
+printComError :: IOError -> IO ()
+printComError ioe = putStrLn (coGetErrorString ioe)
+
+hresultToString :: HRESULT -> IO String
+hresultToString = stringFromHR
+
+coAssert :: Bool -> String -> IO ()
+coAssert True msg    = return ()
+coAssert False msg   = coFail msg
+
+coOnFail :: IO a -> String -> IO a
+coOnFail io msg      = io 
+{- BEGIN_GHC_ONLY 
+    `Control.Exception.catch`
+    (\ err -> 
+       case Control.Exception.ioErrors err of
+         Just i  -> coFail (msg ++ ": " ++ (coGetErrorString i))
+	 Nothing -> coFail msg)
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+    `IO.catch`
+    (\ err -> coFail (msg ++ ": " ++ (coGetErrorString err)))
+{- END_NOT_FOR_GHC -}
+
+coFail :: String -> IO a
+coFail = coFailWithHR e_FAIL 
+\end{code}
+
+\begin{code}
+s_FALSE, s_OK :: HRESULT
+s_OK = 0
+s_FALSE = 1
+
+nOERROR :: HRESULT
+nOERROR = 0 
+
+nO_ERROR :: HRESULT
+nO_ERROR = 0
+
+sEVERITY_ERROR :: Int32
+sEVERITY_ERROR = 1 
+sEVERITY_SUCCESS :: Int32
+sEVERITY_SUCCESS = 0 
+
+succeeded :: HRESULT -> Bool
+succeeded hr = hr >=0
+
+winErrorToHR :: Int32 -> HRESULT
+winErrorToHR 0 = 0
+winErrorToHR x = (fACILITY_WIN32 `shiftL` 16) .|. (bit 31) .|. (x .&. 0xffff)
+
+hRESULT_CODE :: HRESULT -> Int32
+hRESULT_CODE hr = hr .&. (fromIntegral 0xffff)
+
+hRESULT_FACILITY :: HRESULT -> Int32
+hRESULT_FACILITY hr = (hr `shiftR` 16) .&. 0x1fff
+
+hRESULT_SEVERITY :: HRESULT -> Int32
+hRESULT_SEVERITY hr = (hr `shiftR` 31) .&. 0x1
+
+mkHRESULT :: Int32 -> Int32 -> Int32 -> HRESULT
+mkHRESULT sev fac code = 
+  word32ToInt32 (
+      ((int32ToWord32 sev) `shiftL` 31) .|. 
+      ((int32ToWord32 fac) `shiftL` 16) .|.
+      (int32ToWord32 code)
+     )
+
+\end{code}
+
+
+
+\begin{code}
+cAT_E_CATIDNOEXIST :: HRESULT
+cAT_E_CATIDNOEXIST = word32ToInt32 (0x80040160 ::Word32)
+cAT_E_FIRST :: HRESULT
+cAT_E_FIRST = word32ToInt32 (0x80040160 ::Word32)
+cAT_E_LAST :: HRESULT
+cAT_E_LAST = word32ToInt32 (0x80040161 ::Word32)
+cAT_E_NODESCRIPTION :: HRESULT
+cAT_E_NODESCRIPTION = word32ToInt32 (0x80040161 ::Word32)
+cLASS_E_CLASSNOTAVAILABLE :: HRESULT
+cLASS_E_CLASSNOTAVAILABLE = word32ToInt32 (0x80040111 ::Word32)
+cLASS_E_NOAGGREGATION :: HRESULT
+cLASS_E_NOAGGREGATION = word32ToInt32 (0x80040110 ::Word32)
+cLASS_E_NOTLICENSED :: HRESULT
+cLASS_E_NOTLICENSED = word32ToInt32 (0x80040112 ::Word32)
+cO_E_ACCESSCHECKFAILED :: HRESULT
+cO_E_ACCESSCHECKFAILED = word32ToInt32 (0x80040207 ::Word32)
+cO_E_ACESINWRONGORDER :: HRESULT
+cO_E_ACESINWRONGORDER = word32ToInt32 (0x80040217 ::Word32)
+cO_E_ACNOTINITIALIZED :: HRESULT
+cO_E_ACNOTINITIALIZED = word32ToInt32 (0x8004021B ::Word32)
+cO_E_ALREADYINITIALIZED :: HRESULT
+cO_E_ALREADYINITIALIZED = word32ToInt32 (0x800401F1 ::Word32)
+cO_E_APPDIDNTREG :: HRESULT
+cO_E_APPDIDNTREG = word32ToInt32 (0x800401FE ::Word32)
+cO_E_APPNOTFOUND :: HRESULT
+cO_E_APPNOTFOUND = word32ToInt32 (0x800401F5 ::Word32)
+cO_E_APPSINGLEUSE :: HRESULT
+cO_E_APPSINGLEUSE = word32ToInt32 (0x800401F6 ::Word32)
+cO_E_BAD_PATH :: HRESULT
+cO_E_BAD_PATH = word32ToInt32 (0x80080004 ::Word32)
+cO_E_BAD_SERVER_NAME :: HRESULT
+cO_E_BAD_SERVER_NAME = word32ToInt32 (0x80004014 ::Word32)
+cO_E_CANTDETERMINECLASS :: HRESULT
+cO_E_CANTDETERMINECLASS = word32ToInt32 (0x800401F2 ::Word32)
+cO_E_CANT_REMOTE :: HRESULT
+cO_E_CANT_REMOTE = word32ToInt32 (0x80004013 ::Word32)
+cO_E_CLASSSTRING :: HRESULT
+cO_E_CLASSSTRING = word32ToInt32 (0x800401F3 ::Word32)
+cO_E_CLASS_CREATE_FAILED :: HRESULT
+cO_E_CLASS_CREATE_FAILED = word32ToInt32 (0x80080001 ::Word32)
+cO_E_CLSREG_INCONSISTENT :: HRESULT
+cO_E_CLSREG_INCONSISTENT = word32ToInt32 (0x8000401F ::Word32)
+cO_E_CONVERSIONFAILED :: HRESULT
+cO_E_CONVERSIONFAILED = word32ToInt32 (0x8004020B ::Word32)
+cO_E_CREATEPROCESS_FAILURE :: HRESULT
+cO_E_CREATEPROCESS_FAILURE = word32ToInt32 (0x80004018 ::Word32)
+cO_E_DECODEFAILED :: HRESULT
+cO_E_DECODEFAILED = word32ToInt32 (0x8004021A ::Word32)
+cO_E_DLLNOTFOUND :: HRESULT
+cO_E_DLLNOTFOUND = word32ToInt32 (0x800401F8 ::Word32)
+cO_E_ERRORINAPP :: HRESULT
+cO_E_ERRORINAPP = word32ToInt32 (0x800401F7 ::Word32)
+cO_E_ERRORINDLL :: HRESULT
+cO_E_ERRORINDLL = word32ToInt32 (0x800401F9 ::Word32)
+cO_E_EXCEEDSYSACLLIMIT :: HRESULT
+cO_E_EXCEEDSYSACLLIMIT = word32ToInt32 (0x80040216 ::Word32)
+cO_E_FAILEDTOCLOSEHANDLE :: HRESULT
+cO_E_FAILEDTOCLOSEHANDLE = word32ToInt32 (0x80040215 ::Word32)
+cO_E_FAILEDTOCREATEFILE :: HRESULT
+cO_E_FAILEDTOCREATEFILE = word32ToInt32 (0x80040214 ::Word32)
+cO_E_FAILEDTOGENUUID :: HRESULT
+cO_E_FAILEDTOGENUUID = word32ToInt32 (0x80040213 ::Word32)
+cO_E_FAILEDTOGETSECCTX :: HRESULT
+cO_E_FAILEDTOGETSECCTX = word32ToInt32 (0x80040201 ::Word32)
+cO_E_FAILEDTOGETTOKENINFO :: HRESULT
+cO_E_FAILEDTOGETTOKENINFO = word32ToInt32 (0x80040203 ::Word32)
+cO_E_FAILEDTOGETWINDIR :: HRESULT
+cO_E_FAILEDTOGETWINDIR = word32ToInt32 (0x80040211 ::Word32)
+cO_E_FAILEDTOIMPERSONATE :: HRESULT
+cO_E_FAILEDTOIMPERSONATE = word32ToInt32 (0x80040200 ::Word32)
+cO_E_FAILEDTOOPENPROCESSTOKEN :: HRESULT
+cO_E_FAILEDTOOPENPROCESSTOKEN = word32ToInt32 (0x80040219 ::Word32)
+cO_E_FAILEDTOOPENTHREADTOKEN :: HRESULT
+cO_E_FAILEDTOOPENTHREADTOKEN = word32ToInt32 (0x80040202 ::Word32)
+cO_E_FAILEDTOQUERYCLIENTBLANKET :: HRESULT
+cO_E_FAILEDTOQUERYCLIENTBLANKET = word32ToInt32 (0x80040205 ::Word32)
+cO_E_FAILEDTOSETDACL :: HRESULT
+cO_E_FAILEDTOSETDACL = word32ToInt32 (0x80040206 ::Word32)
+cO_E_FIRST :: HRESULT
+cO_E_FIRST = word32ToInt32 (0x800401F0 ::Word32)
+cO_E_IIDREG_INCONSISTENT :: HRESULT
+cO_E_IIDREG_INCONSISTENT = word32ToInt32 (0x80004020 ::Word32)
+cO_E_IIDSTRING :: HRESULT
+cO_E_IIDSTRING = word32ToInt32 (0x800401F4 ::Word32)
+cO_E_INCOMPATIBLESTREAMVERSION :: HRESULT
+cO_E_INCOMPATIBLESTREAMVERSION = word32ToInt32 (0x80040218 ::Word32)
+cO_E_INIT_CLASS_CACHE :: HRESULT
+cO_E_INIT_CLASS_CACHE = word32ToInt32 (0x80004009 ::Word32)
+cO_E_INIT_MEMORY_ALLOCATOR :: HRESULT
+cO_E_INIT_MEMORY_ALLOCATOR = word32ToInt32 (0x80004008 ::Word32)
+cO_E_INIT_ONLY_SINGLE_THREADED :: HRESULT
+cO_E_INIT_ONLY_SINGLE_THREADED = word32ToInt32 (0x80004012 ::Word32)
+cO_E_INIT_RPC_CHANNEL :: HRESULT
+cO_E_INIT_RPC_CHANNEL = word32ToInt32 (0x8000400A ::Word32)
+cO_E_INIT_SCM_EXEC_FAILURE :: HRESULT
+cO_E_INIT_SCM_EXEC_FAILURE = word32ToInt32 (0x80004011 ::Word32)
+cO_E_INIT_SCM_FILE_MAPPING_EXISTS :: HRESULT
+cO_E_INIT_SCM_FILE_MAPPING_EXISTS = word32ToInt32 (0x8000400F ::Word32)
+cO_E_INIT_SCM_MAP_VIEW_OF_FILE :: HRESULT
+cO_E_INIT_SCM_MAP_VIEW_OF_FILE = word32ToInt32 (0x80004010 ::Word32)
+cO_E_INIT_SCM_MUTEX_EXISTS :: HRESULT
+cO_E_INIT_SCM_MUTEX_EXISTS = word32ToInt32 (0x8000400E ::Word32)
+cO_E_INIT_SHARED_ALLOCATOR :: HRESULT
+cO_E_INIT_SHARED_ALLOCATOR = word32ToInt32 (0x80004007 ::Word32)
+cO_E_INIT_TLS :: HRESULT
+cO_E_INIT_TLS = word32ToInt32 (0x80004006 ::Word32)
+cO_E_INIT_TLS_CHANNEL_CONTROL :: HRESULT
+cO_E_INIT_TLS_CHANNEL_CONTROL = word32ToInt32 (0x8000400C ::Word32)
+cO_E_INIT_TLS_SET_CHANNEL_CONTROL :: HRESULT
+cO_E_INIT_TLS_SET_CHANNEL_CONTROL = word32ToInt32 (0x8000400B ::Word32)
+cO_E_INIT_UNACCEPTED_USER_ALLOCATOR :: HRESULT
+cO_E_INIT_UNACCEPTED_USER_ALLOCATOR = word32ToInt32 (0x8000400D ::Word32)
+cO_E_INVALIDSID :: HRESULT
+cO_E_INVALIDSID = word32ToInt32 (0x8004020A ::Word32)
+cO_E_LAST :: HRESULT
+cO_E_LAST = word32ToInt32 (0x800401FF ::Word32)
+cO_E_LAUNCH_PERMSSION_DENIED :: HRESULT
+cO_E_LAUNCH_PERMSSION_DENIED = word32ToInt32 (0x8000401B ::Word32)
+cO_E_LOOKUPACCNAMEFAILED :: HRESULT
+cO_E_LOOKUPACCNAMEFAILED = word32ToInt32 (0x8004020F ::Word32)
+cO_E_LOOKUPACCSIDFAILED :: HRESULT
+cO_E_LOOKUPACCSIDFAILED = word32ToInt32 (0x8004020D ::Word32)
+cO_E_MSI_ERROR :: HRESULT
+cO_E_MSI_ERROR = word32ToInt32 (0x80004023 ::Word32)
+cO_E_NETACCESSAPIFAILED :: HRESULT
+cO_E_NETACCESSAPIFAILED = word32ToInt32 (0x80040208 ::Word32)
+cO_E_NOMATCHINGNAMEFOUND :: HRESULT
+cO_E_NOMATCHINGNAMEFOUND = word32ToInt32 (0x8004020E ::Word32)
+cO_E_NOMATCHINGSIDFOUND :: HRESULT
+cO_E_NOMATCHINGSIDFOUND = word32ToInt32 (0x8004020C ::Word32)
+cO_E_NOTINITIALIZED :: HRESULT
+cO_E_NOTINITIALIZED = word32ToInt32 (0x800401F0 ::Word32)
+cO_E_NOT_SUPPORTED :: HRESULT
+cO_E_NOT_SUPPORTED = word32ToInt32 (0x80004021 ::Word32)
+cO_E_OBJISREG :: HRESULT
+cO_E_OBJISREG = word32ToInt32 (0x800401FC ::Word32)
+cO_E_OBJNOTCONNECTED :: HRESULT
+cO_E_OBJNOTCONNECTED = word32ToInt32 (0x800401FD ::Word32)
+cO_E_OBJNOTREG :: HRESULT
+cO_E_OBJNOTREG = word32ToInt32 (0x800401FB ::Word32)
+cO_E_OBJSRV_RPC_FAILURE :: HRESULT
+cO_E_OBJSRV_RPC_FAILURE = word32ToInt32 (0x80080006 ::Word32)
+cO_E_OLE1DDE_DISABLED :: HRESULT
+cO_E_OLE1DDE_DISABLED = word32ToInt32 (0x80004016 ::Word32)
+cO_E_PATHTOOLONG :: HRESULT
+cO_E_PATHTOOLONG = word32ToInt32 (0x80040212 ::Word32)
+cO_E_RELEASED :: HRESULT
+cO_E_RELEASED = word32ToInt32 (0x800401FF ::Word32)
+cO_E_RELOAD_DLL :: HRESULT
+cO_E_RELOAD_DLL = word32ToInt32 (0x80004022 ::Word32)
+cO_E_REMOTE_COMMUNICATION_FAILURE :: HRESULT
+cO_E_REMOTE_COMMUNICATION_FAILURE = word32ToInt32 (0x8000401D ::Word32)
+cO_E_RUNAS_CREATEPROCESS_FAILURE :: HRESULT
+cO_E_RUNAS_CREATEPROCESS_FAILURE = word32ToInt32 (0x80004019 ::Word32)
+cO_E_RUNAS_LOGON_FAILURE :: HRESULT
+cO_E_RUNAS_LOGON_FAILURE = word32ToInt32 (0x8000401A ::Word32)
+cO_E_RUNAS_SYNTAX :: HRESULT
+cO_E_RUNAS_SYNTAX = word32ToInt32 (0x80004017 ::Word32)
+cO_E_SCM_ERROR :: HRESULT
+cO_E_SCM_ERROR = word32ToInt32 (0x80080002 ::Word32)
+cO_E_SCM_RPC_FAILURE :: HRESULT
+cO_E_SCM_RPC_FAILURE = word32ToInt32 (0x80080003 ::Word32)
+cO_E_SERVER_EXEC_FAILURE :: HRESULT
+cO_E_SERVER_EXEC_FAILURE = word32ToInt32 (0x80080005 ::Word32)
+cO_E_SERVER_START_TIMEOUT :: HRESULT
+cO_E_SERVER_START_TIMEOUT = word32ToInt32 (0x8000401E ::Word32)
+cO_E_SERVER_STOPPING :: HRESULT
+cO_E_SERVER_STOPPING = word32ToInt32 (0x80080008 ::Word32)
+cO_E_SETSERLHNDLFAILED :: HRESULT
+cO_E_SETSERLHNDLFAILED = word32ToInt32 (0x80040210 ::Word32)
+cO_E_START_SERVICE_FAILURE :: HRESULT
+cO_E_START_SERVICE_FAILURE = word32ToInt32 (0x8000401C ::Word32)
+cO_E_TRUSTEEDOESNTMATCHCLIENT :: HRESULT
+cO_E_TRUSTEEDOESNTMATCHCLIENT = word32ToInt32 (0x80040204 ::Word32)
+cO_E_WRONGOSFORAPP :: HRESULT
+cO_E_WRONGOSFORAPP = word32ToInt32 (0x800401FA ::Word32)
+cO_E_WRONGTRUSTEENAMESYNTAX :: HRESULT
+cO_E_WRONGTRUSTEENAMESYNTAX = word32ToInt32 (0x80040209 ::Word32)
+cO_E_WRONG_SERVER_IDENTITY :: HRESULT
+cO_E_WRONG_SERVER_IDENTITY = word32ToInt32 (0x80004015 ::Word32)
+cO_S_FIRST :: HRESULT
+cO_S_FIRST = word32ToInt32 (0x000401F0 ::Word32)
+cO_S_LAST :: HRESULT
+cO_S_LAST = word32ToInt32 (0x000401FF ::Word32)
+cO_S_NOTALLINTERFACES :: HRESULT
+cO_S_NOTALLINTERFACES = word32ToInt32 (0x00080012 ::Word32)
+dISP_E_ARRAYISLOCKED :: HRESULT
+dISP_E_ARRAYISLOCKED = word32ToInt32 (0x8002000D ::Word32)
+dISP_E_BADCALLEE :: HRESULT
+dISP_E_BADCALLEE = word32ToInt32 (0x80020010 ::Word32)
+dISP_E_BADINDEX :: HRESULT
+dISP_E_BADINDEX = word32ToInt32 (0x8002000B ::Word32)
+dISP_E_BADPARAMCOUNT :: HRESULT
+dISP_E_BADPARAMCOUNT = word32ToInt32 (0x8002000E ::Word32)
+dISP_E_BADVARTYPE :: HRESULT
+dISP_E_BADVARTYPE = word32ToInt32 (0x80020008 ::Word32)
+dISP_E_DIVBYZERO :: HRESULT
+dISP_E_DIVBYZERO = word32ToInt32 (0x80020012 ::Word32)
+dISP_E_EXCEPTION :: HRESULT
+dISP_E_EXCEPTION = word32ToInt32 (0x80020009 ::Word32)
+dISP_E_MEMBERNOTFOUND :: HRESULT
+dISP_E_MEMBERNOTFOUND = word32ToInt32 (0x80020003 ::Word32)
+dISP_E_NONAMEDARGS :: HRESULT
+dISP_E_NONAMEDARGS = word32ToInt32 (0x80020007 ::Word32)
+dISP_E_NOTACOLLECTION :: HRESULT
+dISP_E_NOTACOLLECTION = word32ToInt32 (0x80020011 ::Word32)
+dISP_E_OVERFLOW :: HRESULT
+dISP_E_OVERFLOW = word32ToInt32 (0x8002000A ::Word32)
+dISP_E_PARAMNOTFOUND :: HRESULT
+dISP_E_PARAMNOTFOUND = word32ToInt32 (0x80020004 ::Word32)
+dISP_E_PARAMNOTOPTIONAL :: HRESULT
+dISP_E_PARAMNOTOPTIONAL = word32ToInt32 (0x8002000F ::Word32)
+dISP_E_TYPEMISMATCH :: HRESULT
+dISP_E_TYPEMISMATCH = word32ToInt32 (0x80020005 ::Word32)
+dISP_E_UNKNOWNINTERFACE :: HRESULT
+dISP_E_UNKNOWNINTERFACE = word32ToInt32 (0x80020001 ::Word32)
+dISP_E_UNKNOWNLCID :: HRESULT
+dISP_E_UNKNOWNLCID = word32ToInt32 (0x8002000C ::Word32)
+dISP_E_UNKNOWNNAME :: HRESULT
+dISP_E_UNKNOWNNAME = word32ToInt32 (0x80020006 ::Word32)
+dV_E_CLIPFORMAT :: HRESULT
+dV_E_CLIPFORMAT = word32ToInt32 (0x8004006A ::Word32)
+dV_E_DVASPECT :: HRESULT
+dV_E_DVASPECT = word32ToInt32 (0x8004006B ::Word32)
+dV_E_DVTARGETDEVICE :: HRESULT
+dV_E_DVTARGETDEVICE = word32ToInt32 (0x80040065 ::Word32)
+dV_E_DVTARGETDEVICE_SIZE :: HRESULT
+dV_E_DVTARGETDEVICE_SIZE = word32ToInt32 (0x8004006C ::Word32)
+dV_E_FORMATETC :: HRESULT
+dV_E_FORMATETC = word32ToInt32 (0x80040064 ::Word32)
+dV_E_LINDEX :: HRESULT
+dV_E_LINDEX = word32ToInt32 (0x80040068 ::Word32)
+dV_E_NOIVIEWOBJECT :: HRESULT
+dV_E_NOIVIEWOBJECT = word32ToInt32 (0x8004006D ::Word32)
+dV_E_STATDATA :: HRESULT
+dV_E_STATDATA = word32ToInt32 (0x80040067 ::Word32)
+dV_E_STGMEDIUM :: HRESULT
+dV_E_STGMEDIUM = word32ToInt32 (0x80040066 ::Word32)
+dV_E_TYMED :: HRESULT
+dV_E_TYMED = word32ToInt32 (0x80040069 ::Word32)
+e_ABORT :: HRESULT
+e_ABORT = word32ToInt32 (0x80004004 ::Word32)
+e_ACCESSDENIED :: HRESULT
+e_ACCESSDENIED = word32ToInt32 (0x80070005 ::Word32)
+e_FAIL :: HRESULT
+e_FAIL = word32ToInt32 (0x80004005 ::Word32)
+e_HANDLE :: HRESULT
+e_HANDLE = word32ToInt32 (0x80070006 ::Word32)
+e_INVALIDARG :: HRESULT
+e_INVALIDARG = word32ToInt32 (0x80070057 ::Word32)
+e_NOINTERFACE :: HRESULT
+e_NOINTERFACE = word32ToInt32 (0x80004002 ::Word32)
+e_NOTIMPL :: HRESULT
+e_NOTIMPL = word32ToInt32 (0x80004001 ::Word32)
+e_OUTOFMEMORY :: HRESULT
+e_OUTOFMEMORY = word32ToInt32 (0x8007000E ::Word32)
+e_PENDING :: HRESULT
+e_PENDING = word32ToInt32 (0x8000000A ::Word32)
+e_POINTER :: HRESULT
+e_POINTER = word32ToInt32 (0x80004003 ::Word32)
+e_UNEXPECTED :: HRESULT
+e_UNEXPECTED = word32ToInt32 (0x8000FFFF ::Word32)
+
+fACILITY_CERT :: HRESULT
+fACILITY_CERT = 11 
+fACILITY_CONTROL :: HRESULT
+fACILITY_CONTROL = 10 
+fACILITY_DISPATCH :: HRESULT
+fACILITY_DISPATCH = 2 
+fACILITY_INTERNET :: HRESULT
+fACILITY_INTERNET = 12 
+fACILITY_ITF :: HRESULT
+fACILITY_ITF = 4 
+fACILITY_MEDIASERVER :: HRESULT
+fACILITY_MEDIASERVER = 13 
+fACILITY_MSMQ :: HRESULT
+fACILITY_MSMQ = 14 
+fACILITY_NT_BIT :: HRESULT
+fACILITY_NT_BIT = word32ToInt32 (0x10000000 ::Word32)
+fACILITY_NULL :: HRESULT
+fACILITY_NULL = 0 
+fACILITY_RPC :: HRESULT
+fACILITY_RPC = 1 
+fACILITY_SETUPAPI :: HRESULT
+fACILITY_SETUPAPI = 15 
+fACILITY_SSPI :: HRESULT
+fACILITY_SSPI = 9 
+fACILITY_STORAGE :: HRESULT
+fACILITY_STORAGE = 3 
+fACILITY_WIN32 :: HRESULT
+fACILITY_WIN32 = 7 
+fACILITY_WINDOWS :: HRESULT
+fACILITY_WINDOWS = 8 
+
+iNPLACE_E_FIRST :: HRESULT
+iNPLACE_E_FIRST = word32ToInt32 (0x800401A0 ::Word32)
+iNPLACE_E_LAST :: HRESULT
+iNPLACE_E_LAST = word32ToInt32 (0x800401AF ::Word32)
+iNPLACE_E_NOTOOLSPACE :: HRESULT
+iNPLACE_E_NOTOOLSPACE = word32ToInt32 (0x800401A1 ::Word32)
+iNPLACE_E_NOTUNDOABLE :: HRESULT
+iNPLACE_E_NOTUNDOABLE = word32ToInt32 (0x800401A0 ::Word32)
+iNPLACE_S_FIRST :: HRESULT
+iNPLACE_S_FIRST = word32ToInt32 (0x000401A0 ::Word32)
+iNPLACE_S_LAST :: HRESULT
+iNPLACE_S_LAST = word32ToInt32 (0x000401AF ::Word32)
+iNPLACE_S_TRUNCATED :: HRESULT
+iNPLACE_S_TRUNCATED = word32ToInt32 (0x000401A0 ::Word32)
+
+mARSHAL_E_FIRST :: HRESULT
+mARSHAL_E_FIRST = word32ToInt32 (0x80040120 ::Word32)
+mARSHAL_E_LAST :: HRESULT
+mARSHAL_E_LAST = word32ToInt32 (0x8004012F ::Word32)
+mARSHAL_S_FIRST :: HRESULT
+mARSHAL_S_FIRST = word32ToInt32 (0x00040120 ::Word32)
+mARSHAL_S_LAST :: HRESULT
+mARSHAL_S_LAST = word32ToInt32 (0x0004012F ::Word32)
+
+mEM_E_INVALID_LINK :: HRESULT
+mEM_E_INVALID_LINK = word32ToInt32 (0x80080010 ::Word32)
+mEM_E_INVALID_ROOT :: HRESULT
+mEM_E_INVALID_ROOT = word32ToInt32 (0x80080009 ::Word32)
+mEM_E_INVALID_SIZE :: HRESULT
+mEM_E_INVALID_SIZE = word32ToInt32 (0x80080011 ::Word32)
+
+mK_E_CANTOPENFILE :: HRESULT
+mK_E_CANTOPENFILE = word32ToInt32 (0x800401EA ::Word32)
+mK_E_CONNECTMANUALLY :: HRESULT
+mK_E_CONNECTMANUALLY = word32ToInt32 (0x800401E0 ::Word32)
+mK_E_ENUMERATION_FAILED :: HRESULT
+mK_E_ENUMERATION_FAILED = word32ToInt32 (0x800401EF ::Word32)
+mK_E_EXCEEDEDDEADLINE :: HRESULT
+mK_E_EXCEEDEDDEADLINE = word32ToInt32 (0x800401E1 ::Word32)
+mK_E_FIRST :: HRESULT
+mK_E_FIRST = word32ToInt32 (0x800401E0 ::Word32)
+mK_E_INTERMEDIATEINTERFACENOTSUPPORTED :: HRESULT
+mK_E_INTERMEDIATEINTERFACENOTSUPPORTED = word32ToInt32 (0x800401E7 ::Word32)
+mK_E_INVALIDEXTENSION :: HRESULT
+mK_E_INVALIDEXTENSION = word32ToInt32 (0x800401E6 ::Word32)
+mK_E_LAST :: HRESULT
+mK_E_LAST = word32ToInt32 (0x800401EF ::Word32)
+mK_E_MUSTBOTHERUSER :: HRESULT
+mK_E_MUSTBOTHERUSER = word32ToInt32 (0x800401EB ::Word32)
+mK_E_NEEDGENERIC :: HRESULT
+mK_E_NEEDGENERIC = word32ToInt32 (0x800401E2 ::Word32)
+mK_E_NOINVERSE :: HRESULT
+mK_E_NOINVERSE = word32ToInt32 (0x800401EC ::Word32)
+mK_E_NOOBJECT :: HRESULT
+mK_E_NOOBJECT = word32ToInt32 (0x800401E5 ::Word32)
+mK_E_NOPREFIX :: HRESULT
+mK_E_NOPREFIX = word32ToInt32 (0x800401EE ::Word32)
+mK_E_NOSTORAGE :: HRESULT
+mK_E_NOSTORAGE = word32ToInt32 (0x800401ED ::Word32)
+mK_E_NOTBINDABLE :: HRESULT
+mK_E_NOTBINDABLE = word32ToInt32 (0x800401E8 ::Word32)
+mK_E_NOTBOUND :: HRESULT
+mK_E_NOTBOUND = word32ToInt32 (0x800401E9 ::Word32)
+mK_E_NO_NORMALIZED :: HRESULT
+mK_E_NO_NORMALIZED = word32ToInt32 (0x80080007 ::Word32)
+mK_E_SYNTAX :: HRESULT
+mK_E_SYNTAX = word32ToInt32 (0x800401E4 ::Word32)
+mK_E_UNAVAILABLE :: HRESULT
+mK_E_UNAVAILABLE = word32ToInt32 (0x800401E3 ::Word32)
+mK_S_FIRST :: HRESULT
+mK_S_FIRST = word32ToInt32 (0x000401E0 ::Word32)
+mK_S_HIM :: HRESULT
+mK_S_HIM = word32ToInt32 (0x000401E5 ::Word32)
+mK_S_LAST :: HRESULT
+mK_S_LAST = word32ToInt32 (0x000401EF ::Word32)
+mK_S_ME :: HRESULT
+mK_S_ME = word32ToInt32 (0x000401E4 ::Word32)
+mK_S_MONIKERALREADYREGISTERED :: HRESULT
+mK_S_MONIKERALREADYREGISTERED = word32ToInt32 (0x000401E7 ::Word32)
+mK_S_REDUCED_TO_SELF :: HRESULT
+mK_S_REDUCED_TO_SELF = word32ToInt32 (0x000401E2 ::Word32)
+mK_S_US :: HRESULT
+mK_S_US = word32ToInt32 (0x000401E6 ::Word32)
+
+oLEOBJ_E_FIRST :: HRESULT
+oLEOBJ_E_FIRST = word32ToInt32 (0x80040180 ::Word32)
+oLEOBJ_E_INVALIDVERB :: HRESULT
+oLEOBJ_E_INVALIDVERB = word32ToInt32 (0x80040181 ::Word32)
+oLEOBJ_E_LAST :: HRESULT
+oLEOBJ_E_LAST = word32ToInt32 (0x8004018F ::Word32)
+oLEOBJ_E_NOVERBS :: HRESULT
+oLEOBJ_E_NOVERBS = word32ToInt32 (0x80040180 ::Word32)
+oLEOBJ_S_CANNOT_DOVERB_NOW :: HRESULT
+oLEOBJ_S_CANNOT_DOVERB_NOW = word32ToInt32 (0x00040181 ::Word32)
+oLEOBJ_S_FIRST :: HRESULT
+oLEOBJ_S_FIRST = word32ToInt32 (0x00040180 ::Word32)
+oLEOBJ_S_INVALIDHWND :: HRESULT
+oLEOBJ_S_INVALIDHWND = word32ToInt32 (0x00040182 ::Word32)
+oLEOBJ_S_INVALIDVERB :: HRESULT
+oLEOBJ_S_INVALIDVERB = word32ToInt32 (0x00040180 ::Word32)
+oLEOBJ_S_LAST :: HRESULT
+oLEOBJ_S_LAST = word32ToInt32 (0x0004018F ::Word32)
+
+oLE_E_ADVF :: HRESULT
+oLE_E_ADVF = word32ToInt32 (0x80040001 ::Word32)
+oLE_E_ADVISENOTSUPPORTED :: HRESULT
+oLE_E_ADVISENOTSUPPORTED = word32ToInt32 (0x80040003 ::Word32)
+oLE_E_BLANK :: HRESULT
+oLE_E_BLANK = word32ToInt32 (0x80040007 ::Word32)
+oLE_E_CANTCONVERT :: HRESULT
+oLE_E_CANTCONVERT = word32ToInt32 (0x80040011 ::Word32)
+oLE_E_CANT_BINDTOSOURCE :: HRESULT
+oLE_E_CANT_BINDTOSOURCE = word32ToInt32 (0x8004000A ::Word32)
+oLE_E_CANT_GETMONIKER :: HRESULT
+oLE_E_CANT_GETMONIKER = word32ToInt32 (0x80040009 ::Word32)
+oLE_E_CLASSDIFF :: HRESULT
+oLE_E_CLASSDIFF = word32ToInt32 (0x80040008 ::Word32)
+oLE_E_ENUM_NOMORE :: HRESULT
+oLE_E_ENUM_NOMORE = word32ToInt32 (0x80040002 ::Word32)
+oLE_E_FIRST :: HRESULT
+oLE_E_FIRST = word32ToInt32 (0x80040000::Word32)
+oLE_E_INVALIDHWND :: HRESULT
+oLE_E_INVALIDHWND = word32ToInt32 (0x8004000F ::Word32)
+oLE_E_INVALIDRECT :: HRESULT
+oLE_E_INVALIDRECT = word32ToInt32 (0x8004000D ::Word32)
+oLE_E_LAST :: HRESULT
+oLE_E_LAST = word32ToInt32 (0x800400FF::Word32)
+oLE_E_NOCACHE :: HRESULT
+oLE_E_NOCACHE = word32ToInt32 (0x80040006 ::Word32)
+oLE_E_NOCONNECTION :: HRESULT
+oLE_E_NOCONNECTION = word32ToInt32 (0x80040004 ::Word32)
+oLE_E_NOSTORAGE :: HRESULT
+oLE_E_NOSTORAGE = word32ToInt32 (0x80040012 ::Word32)
+oLE_E_NOTRUNNING :: HRESULT
+oLE_E_NOTRUNNING = word32ToInt32 (0x80040005 ::Word32)
+oLE_E_NOT_INPLACEACTIVE :: HRESULT
+oLE_E_NOT_INPLACEACTIVE = word32ToInt32 (0x80040010 ::Word32)
+oLE_E_OLEVERB :: HRESULT
+oLE_E_OLEVERB = word32ToInt32 (0x80040000 ::Word32)
+oLE_E_PROMPTSAVECANCELLED :: HRESULT
+oLE_E_PROMPTSAVECANCELLED = word32ToInt32 (0x8004000C ::Word32)
+oLE_E_STATIC :: HRESULT
+oLE_E_STATIC = word32ToInt32 (0x8004000B ::Word32)
+oLE_E_WRONGCOMPOBJ :: HRESULT
+oLE_E_WRONGCOMPOBJ = word32ToInt32 (0x8004000E ::Word32)
+oLE_S_FIRST :: HRESULT
+oLE_S_FIRST = word32ToInt32 (0x00040000 ::Word32)
+oLE_S_LAST :: HRESULT
+oLE_S_LAST = word32ToInt32 (0x000400FF ::Word32)
+oLE_S_MAC_CLIPFORMAT :: HRESULT
+oLE_S_MAC_CLIPFORMAT = word32ToInt32 (0x00040002 ::Word32)
+oLE_S_STATIC :: HRESULT
+oLE_S_STATIC = word32ToInt32 (0x00040001 ::Word32)
+oLE_S_USEREG :: HRESULT
+oLE_S_USEREG = word32ToInt32 (0x00040000 ::Word32)
+
+pERSIST_E_NOTSELFSIZING :: HRESULT
+pERSIST_E_NOTSELFSIZING = word32ToInt32 (0x800B000B ::Word32)
+pERSIST_E_SIZEDEFINITE :: HRESULT
+pERSIST_E_SIZEDEFINITE = word32ToInt32 (0x800B0009 ::Word32)
+pERSIST_E_SIZEINDEFINITE :: HRESULT
+pERSIST_E_SIZEINDEFINITE = word32ToInt32 (0x800B000A ::Word32)
+
+sTG_E_ABNORMALAPIEXIT :: HRESULT
+sTG_E_ABNORMALAPIEXIT = word32ToInt32 (0x800300FA ::Word32)
+sTG_E_ACCESSDENIED :: HRESULT
+sTG_E_ACCESSDENIED = word32ToInt32 (0x80030005 ::Word32)
+sTG_E_BADBASEADDRESS :: HRESULT
+sTG_E_BADBASEADDRESS = word32ToInt32 (0x80030110 ::Word32)
+sTG_E_CANTSAVE :: HRESULT
+sTG_E_CANTSAVE = word32ToInt32 (0x80030103 ::Word32)
+sTG_E_DISKISWRITEPROTECTED :: HRESULT
+sTG_E_DISKISWRITEPROTECTED = word32ToInt32 (0x80030013 ::Word32)
+sTG_E_DOCFILECORRUPT :: HRESULT
+sTG_E_DOCFILECORRUPT = word32ToInt32 (0x80030109 ::Word32)
+sTG_E_EXTANTMARSHALLINGS :: HRESULT
+sTG_E_EXTANTMARSHALLINGS = word32ToInt32 (0x80030108 ::Word32)
+sTG_E_FILEALREADYEXISTS :: HRESULT
+sTG_E_FILEALREADYEXISTS = word32ToInt32 (0x80030050 ::Word32)
+sTG_E_FILENOTFOUND :: HRESULT
+sTG_E_FILENOTFOUND = word32ToInt32 (0x80030002 ::Word32)
+sTG_E_INCOMPLETE :: HRESULT
+sTG_E_INCOMPLETE = word32ToInt32 (0x80030201 ::Word32)
+sTG_E_INSUFFICIENTMEMORY :: HRESULT
+sTG_E_INSUFFICIENTMEMORY = word32ToInt32 (0x80030008 ::Word32)
+sTG_E_INUSE :: HRESULT
+sTG_E_INUSE = word32ToInt32 (0x80030100 ::Word32)
+sTG_E_INVALIDFLAG :: HRESULT
+sTG_E_INVALIDFLAG = word32ToInt32 (0x800300FF ::Word32)
+sTG_E_INVALIDFUNCTION :: HRESULT
+sTG_E_INVALIDFUNCTION = word32ToInt32 (0x80030001 ::Word32)
+sTG_E_INVALIDHANDLE :: HRESULT
+sTG_E_INVALIDHANDLE = word32ToInt32 (0x80030006 ::Word32)
+sTG_E_INVALIDHEADER :: HRESULT
+sTG_E_INVALIDHEADER = word32ToInt32 (0x800300FB ::Word32)
+sTG_E_INVALIDNAME :: HRESULT
+sTG_E_INVALIDNAME = word32ToInt32 (0x800300FC ::Word32)
+sTG_E_INVALIDPARAMETER :: HRESULT
+sTG_E_INVALIDPARAMETER = word32ToInt32 (0x80030057 ::Word32)
+sTG_E_INVALIDPOINTER :: HRESULT
+sTG_E_INVALIDPOINTER = word32ToInt32 (0x80030009 ::Word32)
+sTG_E_LOCKVIOLATION :: HRESULT
+sTG_E_LOCKVIOLATION = word32ToInt32 (0x80030021 ::Word32)
+sTG_E_MEDIUMFULL :: HRESULT
+sTG_E_MEDIUMFULL = word32ToInt32 (0x80030070 ::Word32)
+sTG_E_NOMOREFILES :: HRESULT
+sTG_E_NOMOREFILES = word32ToInt32 (0x80030012 ::Word32)
+sTG_E_NOTCURRENT :: HRESULT
+sTG_E_NOTCURRENT = word32ToInt32 (0x80030101 ::Word32)
+sTG_E_NOTFILEBASEDSTORAGE :: HRESULT
+sTG_E_NOTFILEBASEDSTORAGE = word32ToInt32 (0x80030107 ::Word32)
+sTG_E_OLDDLL :: HRESULT
+sTG_E_OLDDLL = word32ToInt32 (0x80030105 ::Word32)
+sTG_E_OLDFORMAT :: HRESULT
+sTG_E_OLDFORMAT = word32ToInt32 (0x80030104 ::Word32)
+sTG_E_PATHNOTFOUND :: HRESULT
+sTG_E_PATHNOTFOUND = word32ToInt32 (0x80030003 ::Word32)
+sTG_E_PROPSETMISMATCHED :: HRESULT
+sTG_E_PROPSETMISMATCHED = word32ToInt32 (0x800300F0 ::Word32)
+sTG_E_READFAULT :: HRESULT
+sTG_E_READFAULT = word32ToInt32 (0x8003001E ::Word32)
+sTG_E_REVERTED :: HRESULT
+sTG_E_REVERTED = word32ToInt32 (0x80030102 ::Word32)
+sTG_E_SEEKERROR :: HRESULT
+sTG_E_SEEKERROR = word32ToInt32 (0x80030019 ::Word32)
+sTG_E_SHAREREQUIRED :: HRESULT
+sTG_E_SHAREREQUIRED = word32ToInt32 (0x80030106 ::Word32)
+sTG_E_SHAREVIOLATION :: HRESULT
+sTG_E_SHAREVIOLATION = word32ToInt32 (0x80030020 ::Word32)
+sTG_E_TERMINATED :: HRESULT
+sTG_E_TERMINATED = word32ToInt32 (0x80030202 ::Word32)
+sTG_E_TOOMANYOPENFILES :: HRESULT
+sTG_E_TOOMANYOPENFILES = word32ToInt32 (0x80030004 ::Word32)
+sTG_E_UNIMPLEMENTEDFUNCTION :: HRESULT
+sTG_E_UNIMPLEMENTEDFUNCTION = word32ToInt32 (0x800300FE ::Word32)
+sTG_E_UNKNOWN :: HRESULT
+sTG_E_UNKNOWN = word32ToInt32 (0x800300FD ::Word32)
+sTG_E_WRITEFAULT :: HRESULT
+sTG_E_WRITEFAULT = word32ToInt32 (0x8003001D ::Word32)
+sTG_S_BLOCK :: HRESULT
+sTG_S_BLOCK = word32ToInt32 (0x00030201 ::Word32)
+sTG_S_CANNOTCONSOLIDATE :: HRESULT
+sTG_S_CANNOTCONSOLIDATE = word32ToInt32 (0x00030206 ::Word32)
+sTG_S_CONSOLIDATIONFAILED :: HRESULT
+sTG_S_CONSOLIDATIONFAILED = word32ToInt32 (0x00030205 ::Word32)
+sTG_S_CONVERTED :: HRESULT
+sTG_S_CONVERTED = word32ToInt32 (0x00030200 ::Word32)
+sTG_S_MONITORING :: HRESULT
+sTG_S_MONITORING = word32ToInt32 (0x00030203 ::Word32)
+sTG_S_MULTIPLEOPENS :: HRESULT
+sTG_S_MULTIPLEOPENS = word32ToInt32 (0x00030204 ::Word32)
+sTG_S_RETRYNOW :: HRESULT
+sTG_S_RETRYNOW = word32ToInt32 (0x00030202 ::Word32)
+
+tYPE_E_AMBIGUOUSNAME :: HRESULT
+tYPE_E_AMBIGUOUSNAME = word32ToInt32 (0x8002802C ::Word32)
+tYPE_E_BADMODULEKIND :: HRESULT
+tYPE_E_BADMODULEKIND = word32ToInt32 (0x800288BD ::Word32)
+tYPE_E_BUFFERTOOSMALL :: HRESULT
+tYPE_E_BUFFERTOOSMALL = word32ToInt32 (0x80028016 ::Word32)
+tYPE_E_CANTCREATETMPFILE :: HRESULT
+tYPE_E_CANTCREATETMPFILE = word32ToInt32 (0x80028CA3 ::Word32)
+tYPE_E_CANTLOADLIBRARY :: HRESULT
+tYPE_E_CANTLOADLIBRARY = word32ToInt32 (0x80029C4A ::Word32)
+tYPE_E_CIRCULARTYPE :: HRESULT
+tYPE_E_CIRCULARTYPE = word32ToInt32 (0x80029C84 ::Word32)
+tYPE_E_DLLFUNCTIONNOTFOUND :: HRESULT
+tYPE_E_DLLFUNCTIONNOTFOUND = word32ToInt32 (0x8002802F ::Word32)
+tYPE_E_DUPLICATEID :: HRESULT
+tYPE_E_DUPLICATEID = word32ToInt32 (0x800288C6 ::Word32)
+tYPE_E_ELEMENTNOTFOUND :: HRESULT
+tYPE_E_ELEMENTNOTFOUND = word32ToInt32 (0x8002802B ::Word32)
+tYPE_E_FIELDNOTFOUND :: HRESULT
+tYPE_E_FIELDNOTFOUND = word32ToInt32 (0x80028017 ::Word32)
+tYPE_E_INCONSISTENTPROPFUNCS :: HRESULT
+tYPE_E_INCONSISTENTPROPFUNCS = word32ToInt32 (0x80029C83 ::Word32)
+tYPE_E_INVALIDID :: HRESULT
+tYPE_E_INVALIDID = word32ToInt32 (0x800288CF ::Word32)
+tYPE_E_INVALIDSTATE :: HRESULT
+tYPE_E_INVALIDSTATE = word32ToInt32 (0x80028029 ::Word32)
+tYPE_E_INVDATAREAD :: HRESULT
+tYPE_E_INVDATAREAD = word32ToInt32 (0x80028018 ::Word32)
+tYPE_E_IOERROR :: HRESULT
+tYPE_E_IOERROR = word32ToInt32 (0x80028CA2 ::Word32)
+tYPE_E_LIBNOTREGISTERED :: HRESULT
+tYPE_E_LIBNOTREGISTERED = word32ToInt32 (0x8002801D ::Word32)
+tYPE_E_NAMECONFLICT :: HRESULT
+tYPE_E_NAMECONFLICT = word32ToInt32 (0x8002802D ::Word32)
+tYPE_E_OUTOFBOUNDS :: HRESULT
+tYPE_E_OUTOFBOUNDS = word32ToInt32 (0x80028CA1 ::Word32)
+tYPE_E_QUALIFIEDNAMEDISALLOWED :: HRESULT
+tYPE_E_QUALIFIEDNAMEDISALLOWED = word32ToInt32 (0x80028028 ::Word32)
+tYPE_E_REGISTRYACCESS :: HRESULT
+tYPE_E_REGISTRYACCESS = word32ToInt32 (0x8002801C ::Word32)
+tYPE_E_SIZETOOBIG :: HRESULT
+tYPE_E_SIZETOOBIG = word32ToInt32 (0x800288C5 ::Word32)
+tYPE_E_TYPEMISMATCH :: HRESULT
+tYPE_E_TYPEMISMATCH = word32ToInt32 (0x80028CA0 ::Word32)
+tYPE_E_UNDEFINEDTYPE :: HRESULT
+tYPE_E_UNDEFINEDTYPE = word32ToInt32 (0x80028027 ::Word32)
+tYPE_E_UNKNOWNLCID :: HRESULT
+tYPE_E_UNKNOWNLCID = word32ToInt32 (0x8002802E ::Word32)
+tYPE_E_UNSUPFORMAT :: HRESULT
+tYPE_E_UNSUPFORMAT = word32ToInt32 (0x80028019 ::Word32)
+tYPE_E_WRONGTYPEKIND :: HRESULT
+tYPE_E_WRONGTYPEKIND = word32ToInt32 (0x8002802A ::Word32)
+vIEW_E_DRAW :: HRESULT
+vIEW_E_DRAW = word32ToInt32 (0x80040140 ::Word32)
+vIEW_E_FIRST :: HRESULT
+vIEW_E_FIRST = word32ToInt32 (0x80040140 ::Word32)
+vIEW_E_LAST :: HRESULT
+vIEW_E_LAST = word32ToInt32 (0x8004014F ::Word32)
+vIEW_S_ALREADY_FROZEN :: HRESULT
+vIEW_S_ALREADY_FROZEN = word32ToInt32 (0x00040140 ::Word32)
+vIEW_S_FIRST :: HRESULT
+vIEW_S_FIRST = word32ToInt32 (0x00040140 ::Word32)
+vIEW_S_LAST :: HRESULT
+vIEW_S_LAST = word32ToInt32 (0x0004014F ::Word32)
+\end{code}
+ comlib/ComPrim.hs view
@@ -0,0 +1,672 @@+{-# OPTIONS -#include "comPrim.h" #-}
+-- Automatically generated by HaskellDirect (ihc.exe), version 0.20
+-- Created: 20:11 Pacific Standard Time, Tuesday 16 December, 2003
+-- Command line: -fno-qualified-names -fno-imports -fno-export-lists -fout-pointers-are-not-refs -c ComPrim.idl -o ComPrim.hs
+
+module ComPrim where
+
+
+
+import Pointer ( makeFO, finalNoFree )
+import HDirect
+import Foreign.ForeignPtr
+import Foreign.Ptr
+{- BEGIN_GHC_ONLY
+import Dynamic
+import GHC.IOBase
+--import ForeignObj
+   END_GHC_ONLY -}
+import Int
+import Word       ( Word32
+                   )
+import IOExts     ( unsafePerformIO )
+import WideString ( WideString, marshallWideString, freeWideString,
+		    readWideString, writeWideString )
+import IO         ( hPutStrLn, stderr )
+
+data IUnknown_ a  = Unknown  (ForeignPtr ())
+type IUnknown  a  = IUnknown_ a
+
+type HRESULT = Int32
+
+failed    :: HRESULT -> Bool
+failed hr = hr < 0
+
+ifaceToAddr :: IUnknown a -> Ptr b
+ifaceToAddr (Unknown x)    = castPtr (foreignPtrToPtr x)
+
+addrToIPointer :: Bool -> Ptr b -> IO (IUnknown a)
+addrToIPointer finaliseMe x = do
+  i <- makeFO x (castPtrToFunPtr $ if finaliseMe then addrOfReleaseIUnknown else finalNoFree)
+  return (Unknown i)
+
+marshallIUnknown :: IUnknown a -> IO (ForeignPtr b)
+marshallIUnknown (Unknown x) = return (castForeignPtr x)
+
+checkHR :: HRESULT -> IO ()
+checkHR hr
+      | failed hr   = coFailHR hr
+      | otherwise   = return ()
+
+coFailHR :: HRESULT -> IO a
+coFailHR  hr         = do
+    str <- stringFromHR hr
+    coFailWithHR hr str
+
+{- BEGIN_GHC_ONLY
+-- ghc-specific
+newtype ComError = ComError Int32
+
+comErrorTc = mkTyCon "ComError"
+
+instance Typeable ComError where
+   typeOf _ = mkAppTy comErrorTc []
+
+coFailWithHR :: HRESULT -> String -> IO a
+coFailWithHR hr msg = 
+  ioException (IOError Nothing (DynIOError (toDyn (ComError hr))) "" msg Nothing)
+   END_GHC_ONLY -}
+
+{- BEGIN_NOT_FOR_GHC -}
+coPrefix   = "Com error: "
+
+coFailWithHR :: HRESULT -> String -> IO a
+coFailWithHR hr msg = ioError (userError (coPrefix ++ msg ++ showParen True (shows hr) ""))
+{- END_NOT_FOR_GHC   -}
+
+stringFromHR :: HRESULT -> IO String
+stringFromHR hr = do
+  pstr <- hresultString hr  -- static memory
+  unmarshallString (castPtr pstr)
+
+
+comInitialize :: IO ()
+comInitialize =
+  do
+    o_comInitialize <- prim_ComPrim_comInitialize
+    checkHR o_comInitialize
+
+foreign import stdcall "comInitialize" prim_ComPrim_comInitialize :: IO Int32
+comUnInitialize :: IO ()
+comUnInitialize =
+  prim_ComPrim_comUnInitialize
+
+foreign import stdcall "comUnInitialize" prim_ComPrim_comUnInitialize :: IO ()
+messageBox :: Ptr Char
+           -> Ptr Char
+           -> Word32
+           -> IO ()
+messageBox str title flg =
+  prim_ComPrim_messageBox str
+                          title
+                          flg
+
+foreign import ccall "messageBox" prim_ComPrim_messageBox :: Ptr Char -> Ptr Char -> Word32 -> IO ()
+type PIID = Ptr ()
+type PCLSID = Ptr ()
+type PGUID = Ptr ()
+primCLSIDFromProgID :: Ptr Char
+                    -> PCLSID
+                    -> IO ()
+primCLSIDFromProgID str rptr =
+  do
+    o_primCLSIDFromProgID <- prim_ComPrim_primCLSIDFromProgID str rptr
+    checkHR o_primCLSIDFromProgID
+
+foreign import stdcall "primCLSIDFromProgID" prim_ComPrim_primCLSIDFromProgID :: Ptr Char -> Ptr () -> IO Int32
+primProgIDFromCLSID :: ForeignPtr ()
+                    -> IO (Ptr ())
+primProgIDFromCLSID pclsid =
+  do
+    pwide <- allocBytes (fromIntegral sizeofPtr)
+    o_primProgIDFromCLSID <- withForeignPtr pclsid (\ pclsid -> prim_ComPrim_primProgIDFromCLSID pclsid pwide)
+    checkHR o_primProgIDFromCLSID
+    doThenFree free readPtr pwide
+
+foreign import ccall "primProgIDFromCLSID" prim_ComPrim_primProgIDFromCLSID :: Ptr () -> Ptr (Ptr ()) -> IO Int32
+primStringToGUID :: Ptr Wchar_t
+                 -> Ptr ()
+                 -> IO ()
+primStringToGUID str pguid =
+  do
+    o_primStringToGUID <- prim_ComPrim_primStringToGUID str pguid
+    checkHR o_primStringToGUID
+
+foreign import ccall "primStringToGUID" prim_ComPrim_primStringToGUID :: Ptr Word16 -> Ptr () -> IO Int32
+primGUIDToString :: ForeignPtr ()
+                 -> IO (Ptr ())
+primGUIDToString guid =
+  do
+    str <- allocBytes (fromIntegral sizeofPtr)
+    o_primGUIDToString <- withForeignPtr guid (\ guid -> prim_ComPrim_primGUIDToString guid str)
+    checkHR o_primGUIDToString
+    doThenFree free readPtr str
+
+foreign import ccall "primGUIDToString" prim_ComPrim_primGUIDToString :: Ptr () -> Ptr (Ptr ()) -> IO Int32
+primCopyGUID :: ForeignPtr ()
+             -> PGUID
+             -> IO ()
+primCopyGUID pguid1 pguid2 =
+  do
+    o_primCopyGUID <- withForeignPtr pguid1 (\ pguid1 -> prim_ComPrim_primCopyGUID pguid1 pguid2)
+    checkHR o_primCopyGUID
+
+foreign import ccall "primCopyGUID" prim_ComPrim_primCopyGUID :: Ptr () -> Ptr () -> IO Int32
+primNewGUID :: ForeignPtr ()
+            -> IO ()
+primNewGUID pguid =
+  do
+    o_primNewGUID <- withForeignPtr pguid (\ pguid -> prim_ComPrim_primNewGUID pguid)
+    checkHR o_primNewGUID
+
+foreign import ccall "primNewGUID" prim_ComPrim_primNewGUID :: Ptr () -> IO Int32
+bindObject :: Ptr Wchar_t
+           -> ForeignPtr ()
+           -> IO (Ptr (Ptr ()))
+bindObject name iid =
+  do
+    ppv <- allocBytes (fromIntegral sizeofPtr)
+    o_bindObject <- withForeignPtr iid (\ iid -> prim_ComPrim_bindObject name iid ppv)
+    checkHR o_bindObject
+    return (ppv)
+
+foreign import ccall "bindObject" prim_ComPrim_bindObject :: Ptr Word16 -> Ptr () -> Ptr (Ptr ()) -> IO Int32
+primComEqual :: IUnknown a0
+             -> IUnknown a1
+             -> IO Bool
+primComEqual unk1 unk2 =
+  do
+    unk1 <- marshallIUnknown unk1
+    unk2 <- marshallIUnknown unk2
+    o_primComEqual <- withForeignPtr unk1 (\ unk1 -> withForeignPtr unk2 (\ unk2 -> prim_ComPrim_primComEqual unk1 unk2))
+    unmarshallBool o_primComEqual
+
+foreign import ccall "primComEqual" prim_ComPrim_primComEqual :: Ptr (IUnknown a) -> Ptr (IUnknown a) -> IO Int32
+isEqualGUID :: ForeignPtr ()
+            -> ForeignPtr ()
+            -> Bool
+isEqualGUID guid1 guid2 =
+  unsafePerformIO (withForeignPtr guid1 (\ guid1 -> withForeignPtr guid2 (\ guid2 -> prim_ComPrim_isEqualGUID guid1 guid2)) >>= \ o_isEqualGUID ->
+                   unmarshallBool o_isEqualGUID)
+
+foreign import stdcall "IsEqualGUID" prim_ComPrim_isEqualGUID :: Ptr () -> Ptr () -> IO Int32
+lOCALE_USER_DEFAULT :: Word32
+lOCALE_USER_DEFAULT =
+  unsafePerformIO (prim_ComPrim_lOCALE_USER_DEFAULT)
+
+foreign import ccall "lOCALE_USER_DEFAULT" prim_ComPrim_lOCALE_USER_DEFAULT :: IO Word32
+primCreateTypeLib :: Int32
+                  -> WideString
+                  -> IO (Ptr (Ptr ()))
+primCreateTypeLib skind lpkind =
+  do
+    ppv <- allocBytes (fromIntegral sizeofPtr)
+    lpkind <- marshallWideString lpkind
+    o_primCreateTypeLib <- prim_ComPrim_primCreateTypeLib skind lpkind ppv
+    freeWideString lpkind
+    checkHR o_primCreateTypeLib
+    return (ppv)
+
+foreign import ccall "primCreateTypeLib" prim_ComPrim_primCreateTypeLib :: Int32 -> Ptr WideString -> Ptr (Ptr ()) -> IO Int32
+getLastError :: IO Word32
+getLastError = prim_ComPrim_getLastError
+
+foreign import stdcall "GetLastError" prim_ComPrim_getLastError :: IO Word32
+hresultString :: Int32
+              -> IO (Ptr ())
+hresultString i = prim_ComPrim_hresultString i
+
+foreign import ccall "hresultString" prim_ComPrim_hresultString :: Int32 -> IO (Ptr ())
+coCreateInstance :: ForeignPtr ()
+                 -> ForeignPtr ()
+                 -> Int32
+                 -> ForeignPtr ()
+                 -> Ptr ()
+                 -> IO ()
+coCreateInstance clsid inner ctxt riid ppv =
+  do
+    o_coCreateInstance <- withForeignPtr clsid (\ clsid -> withForeignPtr inner (\ inner -> withForeignPtr riid (\ riid -> prim_ComPrim_coCreateInstance clsid inner ctxt riid ppv)))
+    checkHR o_coCreateInstance
+
+foreign import stdcall "CoCreateInstance" prim_ComPrim_coCreateInstance :: Ptr () -> Ptr () -> Int32 -> Ptr () -> Ptr () -> IO Int32
+type ULONG = Word32
+type DWORD = Word32
+data COAUTHIDENTITY = COAUTHIDENTITY {user :: String,
+                                      domain :: String,
+                                      password :: String,
+                                      flags :: ULONG}
+                        
+writeCOAUTHIDENTITY :: Ptr COAUTHIDENTITY
+                    -> COAUTHIDENTITY
+                    -> IO ()
+writeCOAUTHIDENTITY ptr (COAUTHIDENTITY user domain password flags) =
+  let
+   userLength = (fromIntegral (length user) :: Word32)
+  in
+  do
+    user <- marshallString user
+    let domainLength = (fromIntegral (length domain) :: Word32)
+    domain <- marshallString domain
+    let passwordLength = (fromIntegral (length password) :: Word32)
+    password <- marshallString password
+    let pf0 = ptr
+        pf1 = addNCastPtr pf0 0
+    writePtr pf1 user
+    let pf2 = addNCastPtr pf1 4
+    writeWord32 pf2 userLength
+    let pf3 = addNCastPtr pf2 4
+    writePtr pf3 domain
+    let pf4 = addNCastPtr pf3 4
+    writeWord32 pf4 domainLength
+    let pf5 = addNCastPtr pf4 4
+    writePtr pf5 password
+    let pf6 = addNCastPtr pf5 4
+    writeWord32 pf6 passwordLength
+    let pf7 = addNCastPtr pf6 4
+    writeWord32 pf7 flags
+
+readCOAUTHIDENTITY :: Ptr COAUTHIDENTITY
+                   -> IO COAUTHIDENTITY
+readCOAUTHIDENTITY ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    user <- readPtr pf1
+    let pf2 = addNCastPtr pf1 4
+    userLength <- readWord32 pf2
+    let pf3 = addNCastPtr pf2 4
+    domain <- readPtr pf3
+    let pf4 = addNCastPtr pf3 4
+    domainLength <- readWord32 pf4
+    let pf5 = addNCastPtr pf4 4
+    password <- readPtr pf5
+    let pf6 = addNCastPtr pf5 4
+    passwordLength <- readWord32 pf6
+    let pf7 = addNCastPtr pf6 4
+    flags <- readWord32 pf7
+    userLength <- unmarshallWord32 userLength
+    domainLength <- unmarshallWord32 domainLength
+    passwordLength <- unmarshallWord32 passwordLength
+    user <- unmarshallString user
+    domain <- unmarshallString domain
+    password <- unmarshallString password
+    return (COAUTHIDENTITY user domain password flags)
+
+sizeofCOAUTHIDENTITY :: Word32
+sizeofCOAUTHIDENTITY = 28
+
+data COAUTHINFO = COAUTHINFO {dwAuthnSvc :: DWORD,
+                              dwAuthzSvc :: DWORD,
+                              pwszServerPrincName :: WideString,
+                              dwAuthnLevel :: DWORD,
+                              dwImpersonationLevel :: DWORD,
+                              pAuthIdentityData :: (Maybe COAUTHIDENTITY),
+                              dwCapabilities :: DWORD}
+                    
+writeCOAUTHINFO :: Ptr COAUTHINFO
+                -> COAUTHINFO
+                -> IO ()
+writeCOAUTHINFO ptr (COAUTHINFO dwAuthnSvc dwAuthzSvc pwszServerPrincName dwAuthnLevel dwImpersonationLevel pAuthIdentityData dwCapabilities) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 dwAuthnSvc
+    let pf2 = addNCastPtr pf1 4
+    writeWord32 pf2 dwAuthzSvc
+    let pf3 = addNCastPtr pf2 4
+    writeWideString pf3 pwszServerPrincName
+    let pf4 = addNCastPtr pf3 4
+    writeWord32 pf4 dwAuthnLevel
+    let pf5 = addNCastPtr pf4 4
+    writeWord32 pf5 dwImpersonationLevel
+    let pf6 = addNCastPtr pf5 4
+    writeunique (allocBytes (fromIntegral sizeofCOAUTHIDENTITY)) writeCOAUTHIDENTITY pf6 pAuthIdentityData
+    let pf7 = addNCastPtr pf6 4
+    writeWord32 pf7 dwCapabilities
+
+readCOAUTHINFO :: Ptr COAUTHINFO
+               -> IO COAUTHINFO
+readCOAUTHINFO ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    dwAuthnSvc <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    dwAuthzSvc <- readWord32 pf2
+    let pf3 = addNCastPtr pf2 4
+    pwszServerPrincName <- readWideString pf3
+    let pf4 = addNCastPtr pf3 4
+    dwAuthnLevel <- readWord32 pf4
+    let pf5 = addNCastPtr pf4 4
+    dwImpersonationLevel <- readWord32 pf5
+    let pf6 = addNCastPtr pf5 4
+    pAuthIdentityData <- readunique readCOAUTHIDENTITY pf6
+    let pf7 = addNCastPtr pf6 4
+    dwCapabilities <- readWord32 pf7
+    return (COAUTHINFO dwAuthnSvc dwAuthzSvc pwszServerPrincName dwAuthnLevel dwImpersonationLevel pAuthIdentityData dwCapabilities)
+
+sizeofCOAUTHINFO :: Word32
+sizeofCOAUTHINFO = 28
+
+data COSERVERINFO = COSERVERINFO {dwReserved1 :: DWORD,
+                                  pwszName :: WideString,
+                                  pAuthInfo :: (Maybe COAUTHINFO),
+                                  dwReserved2 :: DWORD}
+                      
+writeCOSERVERINFO :: Ptr COSERVERINFO
+                  -> COSERVERINFO
+                  -> IO ()
+writeCOSERVERINFO ptr (COSERVERINFO dwReserved1 pwszName pAuthInfo dwReserved2) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 dwReserved1
+    let pf2 = addNCastPtr pf1 4
+    writeWideString pf2 pwszName
+    let pf3 = addNCastPtr pf2 4
+    writeunique (allocBytes (fromIntegral sizeofCOAUTHINFO)) writeCOAUTHINFO pf3 pAuthInfo
+    let pf4 = addNCastPtr pf3 4
+    writeWord32 pf4 dwReserved2
+
+readCOSERVERINFO :: Ptr COSERVERINFO
+                 -> IO COSERVERINFO
+readCOSERVERINFO ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    dwReserved1 <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    pwszName <- readWideString pf2
+    let pf3 = addNCastPtr pf2 4
+    pAuthInfo <- readunique readCOAUTHINFO pf3
+    let pf4 = addNCastPtr pf3 4
+    dwReserved2 <- readWord32 pf4
+    return (COSERVERINFO dwReserved1 pwszName pAuthInfo dwReserved2)
+
+sizeofCOSERVERINFO :: Word32
+sizeofCOSERVERINFO = 16
+
+data MULTI_QI_PRIM = MULTI_QI {pIID :: PGUID,
+                               pItf :: (Ptr ()),
+                               hr :: HRESULT}
+                       
+writeMULTI_QI_PRIM :: Ptr MULTI_QI_PRIM
+                   -> MULTI_QI_PRIM
+                   -> IO ()
+writeMULTI_QI_PRIM ptr (MULTI_QI pIID pItf hr) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writePtr pf1 pIID
+    let pf2 = addNCastPtr pf1 4
+    writePtr pf2 pItf
+    let pf3 = addNCastPtr pf2 4
+    writeInt32 pf3 hr
+
+readMULTI_QI_PRIM :: Ptr MULTI_QI_PRIM
+                  -> IO MULTI_QI_PRIM
+readMULTI_QI_PRIM ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    pIID <- readPtr pf1
+    let pf2 = addNCastPtr pf1 4
+    pItf <- readPtr pf2
+    let pf3 = addNCastPtr pf2 4
+    hr <- readInt32 pf3
+    return (MULTI_QI pIID pItf hr)
+
+sizeofMULTI_QI_PRIM :: Word32
+sizeofMULTI_QI_PRIM = 12
+
+coCreateInstanceEx :: ForeignPtr ()
+                   -> ForeignPtr ()
+                   -> DWORD
+                   -> Maybe COSERVERINFO
+                   -> [MULTI_QI_PRIM]
+                   -> IO [MULTI_QI_PRIM]
+coCreateInstanceEx clsid pUnkOuter dwClsCtx pServerInfo pResults =
+  let
+   cmq = (fromIntegral (length pResults) :: Word32)
+  in
+  do
+    pResults <- marshalllist sizeofMULTI_QI_PRIM writeMULTI_QI_PRIM pResults
+    pServerInfo <- marshallunique (allocBytes (fromIntegral sizeofCOSERVERINFO)) writeCOSERVERINFO pServerInfo
+    o_coCreateInstanceEx <- withForeignPtr clsid (\ clsid -> withForeignPtr pUnkOuter (\ pUnkOuter -> prim_ComPrim_coCreateInstanceEx clsid pUnkOuter dwClsCtx pServerInfo cmq pResults))
+    free pServerInfo
+    checkHR o_coCreateInstanceEx
+    cmq <- unmarshallWord32 cmq
+    unmarshalllist sizeofMULTI_QI_PRIM 0 cmq readMULTI_QI_PRIM pResults
+
+foreign import stdcall "CoCreateInstanceEx" prim_ComPrim_coCreateInstanceEx :: Ptr () -> Ptr () -> Word32 -> Ptr COSERVERINFO -> Word32 -> Ptr MULTI_QI_PRIM -> IO Int32
+getActiveObject :: ForeignPtr ()
+                -> Ptr ()
+                -> Ptr ()
+                -> IO ()
+getActiveObject clsid inner ppv =
+  do
+    o_getActiveObject <- withForeignPtr clsid (\ clsid -> prim_ComPrim_getActiveObject clsid inner ppv)
+    checkHR o_getActiveObject
+
+foreign import stdcall "GetActiveObject" prim_ComPrim_getActiveObject :: Ptr () -> Ptr () -> Ptr () -> IO Int32
+primQI :: Ptr ()
+       -> Ptr ()
+       -> ForeignPtr ()
+       -> Ptr (Ptr ())
+       -> IO ()
+primQI methPtr iptr riid ppv =
+  do
+    o_primQI <- withForeignPtr riid (\ riid -> prim_ComPrim_primQI methPtr iptr riid ppv)
+    checkHR o_primQI
+
+foreign import ccall "primQI" prim_ComPrim_primQI :: Ptr () -> Ptr () -> Ptr () -> Ptr (Ptr ()) -> IO Int32
+primAddRef :: Ptr ()
+           -> Ptr ()
+           -> IO Word32
+primAddRef methPtr iptr =
+  prim_ComPrim_primAddRef methPtr
+                          iptr
+
+foreign import ccall "primAddRef" prim_ComPrim_primAddRef :: Ptr () -> Ptr () -> IO Word32
+primRelease :: Ptr ()
+            -> Ptr ()
+            -> IO Word32
+primRelease methPtr iptr =
+  prim_ComPrim_primRelease methPtr
+                           iptr
+
+foreign import ccall "primRelease" prim_ComPrim_primRelease :: Ptr () -> Ptr () -> IO Word32
+primEnumNext :: Ptr ()
+             -> Ptr ()
+             -> Word32
+             -> Ptr ()
+             -> Ptr ()
+             -> IO ()
+primEnumNext methPtr iptr celt ptr po =
+  do
+    o_primEnumNext <- prim_ComPrim_primEnumNext methPtr iptr celt ptr po
+    checkHR o_primEnumNext
+
+foreign import ccall "primEnumNext" prim_ComPrim_primEnumNext :: Ptr () -> Ptr () -> Word32 -> Ptr () -> Ptr () -> IO Int32
+primEnumSkip :: Ptr ()
+             -> Ptr ()
+             -> Word32
+             -> IO ()
+primEnumSkip methPtr iptr celt =
+  do
+    o_primEnumSkip <- prim_ComPrim_primEnumSkip methPtr iptr celt
+    checkHR o_primEnumSkip
+
+foreign import ccall "primEnumSkip" prim_ComPrim_primEnumSkip :: Ptr () -> Ptr () -> Word32 -> IO Int32
+primEnumReset :: Ptr ()
+              -> Ptr ()
+              -> IO ()
+primEnumReset methPtr iptr =
+  do
+    o_primEnumReset <- prim_ComPrim_primEnumReset methPtr iptr
+    checkHR o_primEnumReset
+
+foreign import ccall "primEnumReset" prim_ComPrim_primEnumReset :: Ptr () -> Ptr () -> IO Int32
+primEnumClone :: Ptr ()
+              -> Ptr ()
+              -> Ptr ()
+              -> IO ()
+primEnumClone methPtr iptr ppv =
+  do
+    o_primEnumClone <- prim_ComPrim_primEnumClone methPtr iptr ppv
+    checkHR o_primEnumClone
+
+foreign import ccall "primEnumClone" prim_ComPrim_primEnumClone :: Ptr () -> Ptr () -> Ptr () -> IO Int32
+primPersistLoad :: Ptr ()
+                -> Ptr ()
+                -> Ptr Wchar_t
+                -> Word32
+                -> IO ()
+primPersistLoad methPtr iptr pszFileName dwMode =
+  do
+    o_primPersistLoad <- prim_ComPrim_primPersistLoad methPtr iptr pszFileName dwMode
+    checkHR o_primPersistLoad
+
+foreign import stdcall "primPersistLoad" prim_ComPrim_primPersistLoad :: Ptr () -> Ptr () -> Ptr Word16 -> Word32 -> IO Int32
+primNullIID :: IO (Ptr ())
+primNullIID = prim_ComPrim_primNullIID
+
+foreign import ccall "primNullIID" prim_ComPrim_primNullIID :: IO (Ptr ())
+loadTypeLib :: Ptr Wchar_t
+            -> Ptr ()
+            -> IO ()
+loadTypeLib pfname ptr =
+  do
+    o_loadTypeLib <- prim_ComPrim_loadTypeLib pfname ptr
+    checkHR o_loadTypeLib
+
+foreign import stdcall "LoadTypeLib" prim_ComPrim_loadTypeLib :: Ptr Word16 -> Ptr () -> IO Int32
+loadTypeLibEx :: Ptr Wchar_t
+              -> Int32
+              -> Ptr ()
+              -> IO ()
+loadTypeLibEx pfname rkind ptr =
+  do
+    o_loadTypeLibEx <- prim_ComPrim_loadTypeLibEx pfname rkind ptr
+    checkHR o_loadTypeLibEx
+
+foreign import stdcall "LoadTypeLibEx" prim_ComPrim_loadTypeLibEx :: Ptr Word16 -> Int32 -> Ptr () -> IO Int32
+loadRegTypeLib :: ForeignPtr ()
+               -> Int32
+               -> Int32
+               -> Int32
+               -> Ptr ()
+               -> IO ()
+loadRegTypeLib pguid maj min lcid ptr =
+  do
+    o_loadRegTypeLib <- withForeignPtr pguid (\ pguid -> prim_ComPrim_loadRegTypeLib pguid maj min lcid ptr)
+    checkHR o_loadRegTypeLib
+
+foreign import stdcall "LoadRegTypeLib" prim_ComPrim_loadRegTypeLib :: Ptr () -> Int32 -> Int32 -> Int32 -> Ptr () -> IO Int32
+primQueryPathOfRegTypeLib :: ForeignPtr ()
+                          -> Word16
+                          -> Word16
+                          -> IO (Ptr Wchar_t)
+primQueryPathOfRegTypeLib pgd maj min =
+  withForeignPtr pgd
+                 (\ pgd -> prim_ComPrim_primQueryPathOfRegTypeLib pgd maj min)
+
+foreign import ccall "primQueryPathOfRegTypeLib" prim_ComPrim_primQueryPathOfRegTypeLib :: Ptr () -> Word16 -> Word16 -> IO (Ptr Word16)
+addrOfReleaseIUnknown :: Ptr ()
+addrOfReleaseIUnknown =
+  unsafePerformIO (prim_ComPrim_addrOfReleaseIUnknown)
+
+foreign import stdcall "addrOfReleaseIUnknown" prim_ComPrim_addrOfReleaseIUnknown :: IO (Ptr ())
+bstrToStringLen :: Ptr String
+                -> Int32
+                -> Ptr Char
+                -> IO ()
+bstrToStringLen bstr len str =
+  do
+    o_bstrToStringLen <- prim_ComPrim_bstrToStringLen bstr len str
+    checkHR o_bstrToStringLen
+
+foreign import ccall "bstrToStringLen" prim_ComPrim_bstrToStringLen :: Ptr String -> Int32 -> Ptr Char -> IO Int32
+bstrLen :: Ptr String
+        -> Int32
+bstrLen bstr = unsafePerformIO (prim_ComPrim_bstrLen bstr)
+
+foreign import ccall "bstrLen" prim_ComPrim_bstrLen :: Ptr String -> IO Int32
+stringToBSTR :: Ptr String
+             -> IO (Ptr String)
+stringToBSTR bstr =
+  do
+    res <- allocBytes (fromIntegral sizeofPtr)
+    o_stringToBSTR <- prim_ComPrim_stringToBSTR bstr res
+    checkHR o_stringToBSTR
+    return (res)
+
+foreign import ccall "stringToBSTR" prim_ComPrim_stringToBSTR :: Ptr String -> Ptr String -> IO Int32
+getModuleFileName :: Ptr ()
+                  -> IO String
+getModuleFileName hModule =
+  do
+    o_getModuleFileName <- prim_ComPrim_getModuleFileName hModule
+    doThenFree freeString unmarshallString o_getModuleFileName
+
+foreign import ccall "getModuleFileName" prim_ComPrim_getModuleFileName :: Ptr () -> IO (Ptr String)
+messagePump :: IO ()
+messagePump =
+  prim_ComPrim_messagePump
+
+foreign import ccall "messagePump" prim_ComPrim_messagePump :: IO ()
+postQuitMsg :: IO ()
+postQuitMsg =
+  prim_ComPrim_postQuitMsg
+
+foreign import ccall "postQuitMsg" prim_ComPrim_postQuitMsg :: IO ()
+primOutputDebugString :: String
+                      -> IO ()
+primOutputDebugString msg =
+  do
+    msg <- marshallString msg
+    prim_ComPrim_primOutputDebugString msg
+    freeString msg
+
+foreign import stdcall "OutputDebugString" prim_ComPrim_primOutputDebugString :: Ptr String -> IO ()
+primGetVersionInfo :: IO (Word32, Word32, Word32)
+primGetVersionInfo =
+  do
+    maj <- allocBytes (fromIntegral sizeofWord32)
+    min <- allocBytes (fromIntegral sizeofWord32)
+    pid <- allocBytes (fromIntegral sizeofWord32)
+    prim_ComPrim_primGetVersionInfo maj min pid
+    maj <- doThenFree free readWord32 maj
+    min <- doThenFree free readWord32 min
+    pid <- doThenFree free readWord32 pid
+    return (maj, min, pid)
+
+foreign import stdcall "primGetVersionInfo" prim_ComPrim_primGetVersionInfo :: Ptr Word32 -> Ptr Word32 -> Ptr Word32 -> IO ()
+coRegisterClassObject :: ForeignPtr ()
+                      -> ForeignPtr ()
+                      -> Int32
+                      -> Int32
+                      -> IO Word32
+coRegisterClassObject rclsid pUnk dwClsContext flags0 =
+  do
+    lpwRegister <- allocBytes (fromIntegral sizeofWord32)
+    o_coRegisterClassObject <- withForeignPtr rclsid (\ rclsid -> withForeignPtr pUnk (\ pUnk -> prim_ComPrim_coRegisterClassObject rclsid pUnk dwClsContext flags0 lpwRegister))
+    checkHR o_coRegisterClassObject
+    doThenFree free readWord32 lpwRegister
+
+foreign import stdcall "CoRegisterClassObject" prim_ComPrim_coRegisterClassObject :: Ptr () -> Ptr () -> Int32 -> Int32 -> Ptr Word32 -> IO Int32
+
+ comlib/ComPrim.idl view
@@ -0,0 +1,312 @@+/*
+ IDL spec. for the primitives needed to implement
+ a Haskell COM support library.
+
+ Note: this spec. is processed as a 'normal' FFI spec,
+ not a COM one.
+*/
+stub_include("comPrim.h");
+[pointer_default(ptr)]
+module ComPrim {
+
+hs_quote("
+import Pointer ( makeFO, finalNoFree )
+import HDirect
+import Foreign.ForeignPtr
+import Foreign.Ptr
+{- BEGIN_GHC_ONLY
+import Dynamic
+import GHC.IOBase
+--import ForeignObj
+   END_GHC_ONLY -}
+import Int
+import Word       ( Word32
+                   )
+import IOExts     ( unsafePerformIO )
+import WideString ( WideString, marshallWideString, freeWideString,
+		    readWideString, writeWideString )
+import IO         ( hPutStrLn, stderr )
+
+data IUnknown_ a  = Unknown  (ForeignPtr ())
+type IUnknown  a  = IUnknown_ a
+
+type HRESULT = Int32
+
+failed    :: HRESULT -> Bool
+failed hr = hr < 0
+
+ifaceToAddr :: IUnknown a -> Ptr b
+ifaceToAddr (Unknown x)    = castPtr (foreignPtrToPtr x)
+
+addrToIPointer :: Bool -> Ptr b -> IO (IUnknown a)
+addrToIPointer finaliseMe x = do
+  i <- makeFO x (castPtrToFunPtr $ if finaliseMe then addrOfReleaseIUnknown else finalNoFree)
+  return (Unknown i)
+
+marshallIUnknown :: IUnknown a -> IO (ForeignPtr b)
+marshallIUnknown (Unknown x) = return (castForeignPtr x)
+
+checkHR :: HRESULT -> IO ()
+checkHR hr
+      | failed hr   = coFailHR hr
+      | otherwise   = return ()
+
+coFailHR :: HRESULT -> IO a
+coFailHR  hr         = do
+    str <- stringFromHR hr
+    coFailWithHR hr str
+
+{- BEGIN_GHC_ONLY
+-- ghc-specific
+newtype ComError = ComError Int32
+
+comErrorTc = mkTyCon \"ComError\"
+
+instance Typeable ComError where
+   typeOf _ = mkAppTy comErrorTc []
+
+coFailWithHR :: HRESULT -> String -> IO a
+coFailWithHR hr msg = 
+  ioException (IOError Nothing (DynIOError (toDyn (ComError hr))) \"\" msg Nothing)
+   END_GHC_ONLY -}
+
+{- BEGIN_NOT_FOR_GHC -}
+coPrefix   = \"Com error: \"
+
+coFailWithHR :: HRESULT -> String -> IO a
+coFailWithHR hr msg = ioError (userError (coPrefix ++ msg ++ showParen True (shows hr) \"\"))
+{- END_NOT_FOR_GHC   -}
+
+stringFromHR :: HRESULT -> IO String
+stringFromHR hr = do
+  pstr <- hresultString hr  -- static memory
+  unmarshallString (castPtr pstr)
+
+");
+
+ HRESULT comInitialize(void);
+ void    comUnInitialize(void);
+ 
+ void _cdecl messageBox([in,ptr]char* str,[in,ptr]char* title,[in]unsigned long flg);
+
+ typedef [ptr]void* PIID;
+ typedef [ptr]void* PCLSID;
+
+ typedef [ptr]void* PGUID;
+
+ HRESULT primCLSIDFromProgID( [in,ptr]char*  str
+ 			    , [in,ptr]PCLSID rptr
+			    );
+
+ HRESULT _cdecl
+         primProgIDFromCLSID( [in,foreign]PCLSID pclsid
+ 			    , [out,ref]void** pwide
+			    );
+
+ HRESULT _cdecl
+         primStringToGUID ( [in,ptr]wchar_t* str, [in,ptr]void* pguid);
+ HRESULT _cdecl
+         primGUIDToString ( [in,foreign,ptr]PGUID guid,   [out,ref]void** str);
+
+ HRESULT _cdecl
+         primCopyGUID ( [in,foreign,ptr]PGUID pguid1, [in,ptr]PGUID pguid2);
+	 
+ HRESULT _cdecl
+         primNewGUID ([in,foreign,ptr]PGUID pguid);
+
+ HRESULT _cdecl
+         bindObject ( [in,ptr]wchar_t* name
+ 		    , [in,foreign,ptr]PIID iid
+		    , [out,ptr] void** ppv
+		    );
+ boolean _cdecl
+         primComEqual( [in]IUnknown* unk1, [in]IUnknown* unk2 );
+
+ [pure]boolean IsEqualGUID ([in,foreign,ptr]PGUID guid1, [in,foreign,ptr]PGUID guid2); 
+ 
+ [pure]unsigned long _cdecl lOCALE_USER_DEFAULT();
+ 
+ // Get at the default ICreateTypeLib2 implementation.
+ HRESULT _cdecl
+         primCreateTypeLib 
+             ( [in] long skind
+	     , [in,string]wchar_t* lpkind
+	     , [out,ptr]void** ppv
+	     );
+
+ unsigned int _stdcall GetLastError ();
+
+ void* cdecl hresultString([in]int i);
+
+ HRESULT _stdcall CoCreateInstance
+                   ( [in,foreign]PCLSID clsid
+		   , [in,foreign]void*  inner
+		   , [in]int    ctxt
+		   , [in,foreign,ptr]PGUID riid
+		   , [in,ptr]void* ppv
+		   );
+
+ typedef unsigned long ULONG;
+ typedef unsigned int DWORD;
+
+ typedef struct _COAUTHIDENTITY {
+   [string,size_is(UserLength)]USHORT* User;
+   ULONG UserLength;
+   [string,size_is(DomainLength)]USHORT* Domain;
+   ULONG DomainLength;
+   [string,size_is(PasswordLength)]USHORT* Password;
+   ULONG PasswordLength;
+   ULONG Flags;
+ } COAUTHIDENTITY;
+ 
+ typedef struct _COAUTHINFO {
+   DWORD dwAuthnSvc;
+   DWORD dwAuthzSvc;
+   [string]wchar_t* pwszServerPrincName;
+   DWORD dwAuthnLevel;
+   DWORD dwImpersonationLevel;
+   [unique]COAUTHIDENTITY* pAuthIdentityData;
+   DWORD dwCapabilities;
+ } COAUTHINFO;
+ 
+ typedef struct _COSERVERINFO {
+   DWORD dwReserved1;
+   [string]wchar_t* pwszName;
+   [unique]COAUTHINFO* pAuthInfo;
+   DWORD dwReserved2;
+ } COSERVERINFO;
+ 
+ typedef struct _MULTI_QI {
+   [ptr]PGUID pIID;
+   [ptr]void* pItf;
+   HRESULT hr;
+ } MULTI_QI_PRIM;
+ 
+ HRESULT _stdcall CoCreateInstanceEx
+                   ( [in,foreign]PCLSID clsid
+		   , [in,foreign]void*  pUnkOuter
+		   , [in]DWORD          dwClsCtx
+		   , [in,unique]COSERVERINFO* pServerInfo
+		   , [in]ULONG cmq
+		   , [in,out,size_is(cmq),length_is(cmq)]MULTI_QI_PRIM* pResults
+		   );
+ 
+
+ HRESULT _stdcall GetActiveObject
+                   ( [in,foreign]PCLSID clsid
+		   , [in,ptr]void* inner // should be a foreign
+		   , [in,ptr]void* ppv
+		   );
+ HRESULT _cdecl
+         primQI ( [in,ptr]void*  methPtr
+                , [in,ptr]void*  iptr
+		, [in,foreign]PCLSID riid
+		, [in,ptr]void** ppv
+		);
+ unsigned int _cdecl
+          primAddRef
+                ( [in,ptr]void*  methPtr
+                , [in,ptr]void*  iptr
+		);
+ unsigned int _cdecl
+          primRelease
+                ( [in,ptr]void*  methPtr
+                , [in,ptr]void*  iptr
+		);
+
+ HRESULT  _cdecl
+          primEnumNext
+                ( [in,ptr]void*  methPtr
+                , [in,ptr]void* iptr
+		, [in]unsigned int celt
+		, [in,ptr]void*  ptr
+		, [in,ptr]void*  po
+		);
+ HRESULT  _cdecl
+          primEnumSkip
+                ( [in,ptr]void*  methPtr
+                , [in,ptr]void*  iptr
+		, [in]unsigned int celt
+		);
+ HRESULT  _cdecl
+          primEnumReset
+                ( [in,ptr]void* methPtr
+                , [in,ptr]void* iptr
+		);
+ HRESULT  _cdecl
+          primEnumClone
+                ( [in,ptr]void*  methPtr
+                , [in,ptr]void*  iptr
+                , [in,ptr]void*  ppv
+		);
+
+ HRESULT  _stdcall
+          primPersistLoad
+                ( [in,ptr]void*     methPtr
+                , [in,ptr]void*     iptr
+                , [in,ptr]wchar_t*  pszFileName
+		, [in]unsigned int  dwMode
+		);
+
+ void* _cdecl primNullIID();
+
+ HRESULT _stdcall LoadTypeLib 
+                ( [in,ptr]wchar_t* pfname
+		, [in,ptr]void* ptr
+		);
+ HRESULT _stdcall LoadTypeLibEx
+                ( [in,ptr]wchar_t* pfname
+		, [in]int   rkind
+		, [in,ptr]void* ptr
+		);
+ HRESULT _stdcall LoadRegTypeLib 
+                ( [in,foreign,ptr]PGUID pguid
+		, [in]int   maj
+		, [in]int   min
+		, [in]int   lcid
+		, [in,ptr]void* ptr
+		);
+
+ [ptr]wchar_t* 
+      _cdecl primQueryPathOfRegTypeLib
+ 		( [in,foreign,ptr]PGUID pgd
+		, [in]unsigned short   maj
+		, [in]unsigned short   min
+		);
+
+ [pure]void* addrOfReleaseIUnknown();
+
+ //
+ // BSTR operations
+ //
+ HRESULT  _cdecl bstrToStringLen ([in,ptr]BSTR* bstr,[in]int len, [in,ptr]char* str);
+ // length of bstrs (in 8-bit byte units).
+ [pure]int _cdecl bstrLen ([in,ptr]BSTR* bstr);
+ HRESULT   _cdecl stringToBSTR ([in,ptr]BSTR* bstr, [out,ptr]BSTR* res);
+
+ [string]char* _cdecl getModuleFileName ( [in,ptr]void* hModule);
+ 
+ // Used by stand-alone clients to 
+ void _cdecl messagePump();
+ void _cdecl postQuitMsg();
+
+ // a little bit of useful Win32 functionality seeping through.
+ [call_as("OutputDebugString")]
+ void primOutputDebugString( [in,string]char* msg );
+
+ void primGetVersionInfo
+         ( [out,ref]unsigned long* maj
+	 , [out,ref]unsigned long* min
+	 , [out,ref]unsigned long* pid
+	 );
+
+ HRESULT _stdcall 
+         CoRegisterClassObject 
+             ( [in,foreign]PCLSID rclsid
+	     , [in,foreign]void*  pUnk
+	     , [in] long dwClsContext
+	     , [in] long flags
+	     , [out,ref] unsigned long* lpwRegister
+	     );
+
+}
+ comlib/ComPrimSrc.c view
@@ -0,0 +1,604 @@+/* #define DEBUG */
+
+/* If you don't want the 'stack' allocator, comment this out */
+/* #define USESTACK */
+
+#ifndef COM
+#define COM
+#endif
+
+/* define the DLL export macro */
+#if defined(_WIN32) && !defined(__CYGWIN32__) && !defined(__MINGW32__)
+#define DLLEXPORT(res)  __declspec(dllexport) res
+#else
+/* redef this default for your system */
+#define DLLEXPORT(res)  extern res
+#endif
+
+
+#ifdef COM
+#define COBJMACROS
+#define CINTERFACE
+#endif
+
+#include <stdio.h>
+
+#ifdef _MSC_VER
+#include <windows.h>
+#else
+#include <stdlib.h>
+#include "comPrim.h"
+#include "PointerSrc.h"
+#endif
+
+#define MAXSZ 255
+
+const IID IID_NULL = {0x00000000L, 0x0000, 0x0000, {0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}};
+#ifndef _MSC_VER
+const IID IID_IUnknown = {0x00000000L, 0x0000, 0x0000, {0xC0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x46}};
+const IID IID_IClassFactory = {0x00000001L, 0x0000, 0x0000, {0xC0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x46}};
+#endif
+
+DLLEXPORT(char*) hresultString( HRESULT hr )
+{
+   static char msgbuf[256];
+   int len;
+
+   sprintf( msgbuf, "(0x%lx) ", hr );
+   len = strlen(msgbuf);
+
+   FormatMessageA(
+        FORMAT_MESSAGE_FROM_SYSTEM,
+        NULL,
+        hr,
+        MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL),
+        msgbuf + len,
+        256,
+        NULL
+    );
+
+    return msgbuf;
+}
+
+
+HRESULT primStringToGUID( WCHAR* guidStr, GUID* guid )
+{
+   if (guid) return CLSIDFromString( guidStr, guid );
+        else  return E_OUTOFMEMORY;
+}
+
+HRESULT primGUIDToString( CLSID* guid, WCHAR** guidStr )
+{
+   CLSID* rclsid;
+   HRESULT hr;
+
+   rclsid = (CLSID*)guid;
+
+   if (!rclsid)   rclsid = (CLSID*)&IID_NULL;
+   if (guidStr) {
+      hr = StringFromCLSID( rclsid, guidStr  );
+   } else {
+      hr = E_POINTER;
+   }
+   return hr;
+}
+
+HRESULT primProgIDFromCLSID( const CLSID* clsid, WCHAR** clsidStr )
+{
+   if (!clsid)   clsid = &IID_NULL;
+   if (clsidStr) return ProgIDFromCLSID( clsid, clsidStr );
+            else return E_POINTER;
+}
+
+
+/*-----------------------------------------------------------
+-- Com library calls
+-----------------------------------------------------------*/
+
+static int com_already_initialized = 0;
+static int com_already_uninitialized = 0;
+
+HRESULT comInitialize(void)
+{
+   if (!com_already_initialized) {
+      com_already_initialized = 1;
+      return OleInitialize(NULL);
+   } else {
+      return S_OK;
+   }
+   
+}
+
+void shutdown__()
+{
+  OleUninitialize();
+  com_already_initialized = 0;
+  com_already_uninitialized = 0;
+}
+
+void comUnInitialize(void)
+{
+  if (!com_already_uninitialized) {
+     com_already_uninitialized=1;
+     atexit(shutdown__);
+  }
+}
+
+/*-----------------------------------------------------------
+-- Object Creation
+-----------------------------------------------------------*/
+
+/* CLSIDFromProgID is a bit too naive, so I wrote it myself */
+HRESULT primCLSIDFromProgID( const char* progid, CLSID* clsid )
+{
+  HRESULT hr;
+  char  name[MAXSZ];
+  DWORD namesz = MAXSZ;
+  BYTE  value[MAXSZ];
+  DWORD valuesz = MAXSZ;
+  WCHAR clsidName[MAXSZ];
+  DWORD type   = REG_SZ;
+  HKEY  key    = 0;
+  HKEY  subkey = 0;
+
+  if (!clsid)   return E_POINTER;
+  if (!progid)  return E_POINTER;
+
+  hr = HRESULT_FROM_WIN32(RegOpenKeyExA( HKEY_CLASSES_ROOT, progid, 0, KEY_READ, &key ));
+  if (FAILED(hr)) return CO_E_CLASSSTRING;
+
+  hr = HRESULT_FROM_WIN32(RegOpenKeyExA( key, "CurVer", 0, KEY_READ, &subkey ));
+  if (SUCCEEDED(hr))
+  {
+     hr = HRESULT_FROM_WIN32(RegEnumValueA( subkey, 0, name, &namesz, NULL, &type, value, &valuesz));
+     RegCloseKey( key );
+     RegCloseKey( subkey );
+     if (FAILED(hr)) return hr;
+
+     hr = HRESULT_FROM_WIN32(RegOpenKeyExA( HKEY_CLASSES_ROOT, (char*)value, 0, KEY_QUERY_VALUE, &key ));
+     if (FAILED(hr)) return CO_E_CLASSSTRING;
+
+     namesz  = MAXSZ;
+     valuesz = MAXSZ;
+  }
+
+  hr = HRESULT_FROM_WIN32(RegOpenKeyExA( key, "CLSID", 0, KEY_READ, &subkey ));
+  if (FAILED(hr)) { RegCloseKey( key ); return CO_E_CLSREG_INCONSISTENT; };
+
+  hr = HRESULT_FROM_WIN32(RegEnumValueA( subkey, 0, name, &namesz, NULL, &type,value,&valuesz));
+  RegCloseKey( subkey );
+  RegCloseKey( key );
+  if (FAILED(hr)) return hr;
+
+  mbstowcs( clsidName, (char*)value, MAXSZ );
+  hr = CLSIDFromString( clsidName, clsid );
+
+  return hr;
+}
+
+/* Newer COM libraries supply the functionality of
+   bindObject() via CoGetObject(), but to avoid depending
+   on that being around, we stick with our own implementation.
+*/
+HRESULT bindObject( const WCHAR* name, IID* iid, void** unk )
+{
+  HRESULT hr;
+  IBindCtx    *bc;
+  IMoniker    *mk;
+  ULONG        count;
+
+  if (!unk) return E_POINTER;
+       else *unk = NULL;
+  if (!iid) return E_POINTER;
+
+  bc = NULL;
+  mk = NULL;
+
+  hr = CreateBindCtx(0, &bc);
+  if (FAILED(hr)) return hr;
+
+  hr = MkParseDisplayName(bc, name, &count, &mk);
+  if (FAILED(hr)) { IUnknown_Release(bc); return hr; }
+
+  hr = IMoniker_BindToObject( mk, bc, NULL, iid, unk );
+  IUnknown_Release(mk);
+  IUnknown_Release(bc);
+
+  return hr;
+}
+
+typedef HRESULT (__stdcall * qi_methPtrTy)(void*,void*,void**);
+
+HRESULT primQI ( /*[in]*/void*  methPtr
+	       , /*[in]*/void*  iptr
+	       , /*[in]*/void*  riid
+	       , /*[in]*/void** ppv
+	       )
+{
+ return ((qi_methPtrTy)methPtr)(iptr,riid,ppv);
+}
+
+typedef unsigned int (__stdcall * addRef_methPtrTy)(void*);
+ 
+unsigned int
+primAddRef ( /*[in]*/void*  methPtr
+	   , /*[in]*/void*  iptr
+	   )
+{
+ return ((addRef_methPtrTy)methPtr)(iptr);
+}
+
+typedef unsigned int (__stdcall * release_methPtrTy)(void*);
+ 
+unsigned int
+primRelease ( /*[in]*/void*  methPtr
+	    , /*[in]*/void*  iptr
+	    )
+{
+ return ((release_methPtrTy)methPtr)(iptr);
+}
+
+typedef unsigned int (__stdcall * enumNext_methPtrTy)(void* iptr, unsigned int celt, void* ptr, void* po);
+
+HRESULT
+primEnumNext(void* methPtr, void* iptr, unsigned int celt, void* ptr, void* po)
+{
+ return ((enumNext_methPtrTy)methPtr)(iptr,celt,ptr,po);
+
+}
+
+typedef unsigned int (__stdcall * enumSkip_methPtrTy)(void* iptr, unsigned int celt);
+
+HRESULT
+primEnumSkip(void* methPtr, void* iptr, unsigned int celt)
+{
+ return ((enumSkip_methPtrTy)methPtr)(iptr,celt);
+
+}
+
+typedef unsigned int (__stdcall * enumReset_methPtrTy)(void* iptr);
+
+HRESULT
+primEnumReset(void* methPtr, void* iptr)
+{
+ return ((enumReset_methPtrTy)methPtr)(iptr);
+}
+
+typedef unsigned int (__stdcall * enumClone_methPtrTy)(void* iptr,void* ppv);
+
+HRESULT
+primEnumClone(void* methPtr, void* iptr, void* ppv)
+{
+ return ((enumClone_methPtrTy)methPtr)(iptr,ppv);
+
+}
+
+typedef unsigned int (__stdcall * persistLoad_methPtrTy)(void* iptr,void* pszFileName,unsigned int dwMode);
+
+HRESULT
+primPersistLoad(void* methPtr, void* iptr, void* pszFileName, unsigned int dwMode)
+{
+ return ((persistLoad_methPtrTy)methPtr)(iptr,pszFileName,dwMode);
+}
+
+HRESULT primGetActiveObject( CLSID* clsid, IUnknown** unk )
+{
+  if (!unk) return E_POINTER;
+       else *unk = NULL;
+  return GetActiveObject( clsid, NULL, unk );
+}
+
+HRESULT primLoadRegTypeLib 
+                        ( GUID* rguid
+			, short wMaj
+			, short wMin
+			, LCID lcid
+			, void** ppv
+			)
+{
+  HRESULT hr;
+
+  hr = LoadRegTypeLib(rguid, wMaj, wMin, GetUserDefaultLCID(), (IUnknown**)ppv);
+  return hr;  
+}
+
+
+void messageBox (char* str, char* t, unsigned long x)
+{
+ MessageBox ( NULL, str, t, x);
+ return;
+}
+
+IID* primNullIID () { return (IID*)(&IID_NULL); }
+
+DWORD
+lOCALE_USER_DEFAULT()
+{ 
+ return(GetUserDefaultLCID());
+}
+
+BOOL  primComEqual( IUnknown* unk1, IUnknown* unk2 )
+{
+   IUnknown* obj1;
+   IUnknown* obj2;
+   BOOL    res;
+   HRESULT hr;
+
+   if (!unk1)  return (unk2 == NULL);
+   if (!unk2)  return FALSE;
+
+   hr = IUnknown_QueryInterface( unk1, &IID_IUnknown, (void**)&obj1 );
+   if (FAILED(hr)) return FALSE;
+   hr = IUnknown_QueryInterface( unk2, &IID_IUnknown, (void**)&obj2 );
+   if (FAILED(hr)) {IUnknown_Release(obj1); return FALSE; }
+
+   res = (obj1 == obj2);
+   IUnknown_Release(obj1);
+   IUnknown_Release(obj2);
+   return res;
+}
+
+HRESULT
+primCopyGUID (GUID* g1, GUID* g2)
+{
+  if (g2 == NULL || g1 == NULL) {
+    return E_FAIL;
+  } else {
+    memcpy(g2,g1,sizeof(GUID));
+    return S_OK;
+  }
+}
+
+HRESULT
+primNewGUID (GUID* g1)
+{
+  if (g1 == NULL) {
+    return E_FAIL;
+  } else {
+    return CoCreateGuid(g1);
+  }
+}
+
+
+/*
+ *
+ * CreateTypeLib() stub.
+ *
+ */
+HRESULT primCreateTypeLib ( int i, LPOLESTR fname, void** ppv )
+{
+  /* Not much point really of defining this stub, since
+   * should really be using the FFI, but a little bit
+   * easier to debug this way until we know everything's reaonable
+   * stable.
+   */
+
+  /* Unfortunately, the cygwin/mingw liboleaut32.a import library doesn't have an entry
+   * for _CreateTypeLib@12, so you either have to generate your own version of it (which
+   * I did), or fall back on CreateTypeLib().
+   */
+#ifdef _MSC
+  return ( CreateTypeLib2(1/*SYS_WIN32*/, fname, ppv) );
+#else
+  return ( CreateTypeLib(1/*SYS_WIN32*/, fname, ppv) );
+#endif
+}
+
+BSTR primQueryPathOfRegTypeLib ( GUID* rguid
+			       , unsigned short maj
+			       , unsigned short min
+			       )
+{
+  BSTR bs;
+  HRESULT hr;
+  bs = SysAllocStringByteLen (NULL, 255);
+  
+  hr = QueryPathOfRegTypeLib ( rguid, maj, min, GetUserDefaultLCID(), &bs);
+  
+  if (FAILED(hr)) {
+     SysFreeString(bs);
+     return NULL;
+  }
+  return bs;
+}
+
+#define MAX_LEN_MOD_FNAME 2048
+
+char*
+getModuleFileName ( HANDLE hMod)
+{
+  char* buf = malloc(sizeof(char) * MAX_LEN_MOD_FNAME);
+  DWORD len;
+
+  len = GetModuleFileNameA(hMod, buf, MAX_LEN_MOD_FNAME);
+  return buf;
+
+}
+
+/*-----------------------------------------------------------
+-- Message pumping utils
+-----------------------------------------------------------*/
+void messagePump()
+{
+  MSG msg;
+
+  while ( GetMessage(&msg, 0, 0, 0) ) {
+    DispatchMessage(&msg);
+  }
+}
+
+HANDLE
+mkEvent()
+{
+  return CreateEvent(NULL, FALSE, FALSE, NULL);
+}
+
+void
+waitForEvent (HANDLE h)
+{
+  HANDLE ha = h;
+  DWORD dwR;
+  MSG msg;
+
+  while(1) {
+    dwR = MsgWaitForMultipleObjects(1, &ha, FALSE, INFINITE, QS_ALLEVENTS);
+    if (dwR == WAIT_OBJECT_0) {
+       break;
+    } else {
+      while (PeekMessage(&msg,NULL, 0, 0, PM_REMOVE)) {
+	TranslateMessage(&msg);
+	DispatchMessage(&msg);
+      }
+    }
+  }
+    
+}
+
+void
+signalEvent(HANDLE h)
+{
+  SetEvent(h);
+}
+
+/* Add a WM_QUIT to the STA thread's message queue, causing the
+   above pump to shutdown.
+ */
+void postQuitMsg()
+{
+ PostMessage(NULL, WM_QUIT, 0, 0); 
+}
+
+/*-----------------------------------------------------------
+-- BSTR  <--> String operations:
+-----------------------------------------------------------*/
+
+HRESULT
+stringToBSTR( /*[in,ptr]*/const char* pstrz
+	    , /*[out]*/ BSTR* pbstr
+	    )
+{
+  int i;
+
+  if (!pbstr) {
+    return E_FAIL;
+  } else {
+    *pbstr = NULL;
+  }
+  if (!pstrz) {
+    return S_OK;
+  }
+
+  i = MultiByteToWideChar(CP_ACP, 0, pstrz, -1, NULL, 0);
+  if ( i < 0 ) {
+    return E_FAIL;
+  }
+
+  /* i is the length of the string *including* the null-terminator
+   * (which we don't want in the BSTR).  So the length of the BSTR is
+   * i-1.
+   */
+  *pbstr = SysAllocStringLen(NULL,i-1);
+  if (*pbstr != NULL) {
+    MultiByteToWideChar(CP_ACP, 0, pstrz, -1, *pbstr, i-1); 
+    return S_OK;
+  } else {
+    return E_FAIL;
+  }
+}
+
+int
+bstrLen( /*[in]*/ BSTR bstr )
+{
+   if (!bstr) {
+      return 0;
+   }
+   //   return wcstombs( NULL, bstr, SysStringLen(bstr)+1);
+   return WideCharToMultiByte ( CP_ACP, 0, bstr, SysStringLen(bstr)
+   			      , NULL, 0, NULL, NULL);
+}
+
+HRESULT
+bstrToStringLen ( BSTR bstr
+                , int len
+	        , char* p
+	        )
+{
+  int i;
+  if (!p) {
+     return E_FAIL;
+  } else {
+     *p = '\0';
+  }
+  if (!bstr) {
+     return E_FAIL;
+  }
+  //  i = wcstombs(p,bstr,len+1);
+  i = WideCharToMultiByte ( CP_ACP, 0, bstr, SysStringLen(bstr)
+		          , p, len, NULL, NULL);
+  if ( i == 0 ) {
+     return E_FAIL;
+  } else {
+     p[i]= '\0';
+     return S_OK;
+  }
+}
+
+/*
+ * Wrapper for the interesting bits of GetVersionEx()
+ */
+void
+primGetVersionInfo
+    ( /*[out]*/unsigned long* maj
+    , /*[out]*/unsigned long* min
+    , /*[out]*/unsigned long* pid
+    )
+{
+  OSVERSIONINFO oe;
+  BOOL b;
+  
+  oe.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+  
+  b = GetVersionEx(&oe);
+  
+#ifdef DEBUG
+  if (!b) {
+    fprintf(stderr, "GetVersionEx failed\n");
+    exit(1);
+  }
+#endif
+  /* Assume everything went well */
+  *maj = oe.dwMajorVersion;
+  *min = oe.dwMinorVersion;
+  *pid = oe.dwPlatformId;
+
+  return;
+}
+
+/*
+ * IUnknown finaliser called by GC when ForeignObjs holding them 
+ * are finalised.
+ */
+
+void
+releaseIUnknown__(void* ip)
+{
+  DWORD d;
+#ifdef DEBUG
+  fprintf(stderr, "Releasing COM i-pointer 0x%p\n", ip); fflush(stderr);
+#endif
+  if (ip) {
+    d = IUnknown_Release((IUnknown*)ip);
+#ifdef DEBUG
+    fprintf(stderr, "Released COM i-pointer 0x%p %d\n", ip, d); fflush(stderr);
+#endif
+  }
+}
+
+void*
+addrOfReleaseIUnknown()
+{
+  /* Strictly speaking, converting a function pointer to a void*
+     is not guaranteed to be information preserving in ANSI C.
+  */
+  return (void*)&releaseIUnknown__;
+}
+ comlib/ComServ.lhs view
@@ -0,0 +1,738 @@+%
+% (c) Sigbjorn Finne, 1998-99
+%
+
+Support code for writing Haskell COM components (yay!)
+
+The library code for Haskell COM components (aka. servers),
+support the wrapping up of a bunch of Haskell function values
+into the binary representation that the COM spec mandates.
+
+The library has two classes of 'users':
+
+  - HaskellDirect generated stubs for interfaces representing
+    Haskell COM components.
+  - on-the-fly generation of COM interface pointers by a Haskell
+    application.
+
+i.e., in short, we care about having a simple, programmer-useable, API :-)
+
+\begin{code}
+{-# OPTIONS -#include "ComServ_stub.h" #-}
+{-# OPTIONS -#include "comPrim.h" #-}
+module ComServ 
+	(
+	  createComInstance  -- :: String
+	                     -- -> objState
+			     -- -> IO ()
+			     -- -> [ComInterface objState]
+			     -- -> IID iid
+			     -- -> IO (IUnknown iid)
+
+        , createInstance     -- :: objState
+			     -- -> VTable iid objState
+			     -- -> IO (IUnknown iid)
+			  
+	, createVTable	    -- :: [Ptr ()] -> IO (VTable iid objState)
+           -- prefixes the three IU methods.
+	, createComVTable   -- :: [Ptr ()] -> IO (ComVTable iid objState)
+
+	, createIPointer  -- :: StablePtr a
+	                  -- -> (VTable b)
+			  -- -> IO (PrimIP b)
+	, cloneIPointer      -- :: IUnknown a -> VTable b -> IO (PrimIP b)
+	, cloneIPointer_prim -- :: PrimIP a -> VTable b -> IO (PrimIP b)
+
+        , getObjState      -- :: PrimIP a -> IO b
+        , getRealObjState  -- :: PrimIP a -> IO b
+
+	, createDualInterface -- :: [Ptr ()]
+		              -- -> IID iid
+		              -- -> Either LIBID String
+		              -- -> IUnknown a
+		              -- -> IO (IDispatch ())
+
+        , createDispInterface -- :: IUnknown iid        -- the interface to delegate to
+		              -- -> Either LIBID String -- libid of type library to use.
+		              -- -> IID iid      
+		                         -- what interface it implements (needed to
+			                 -- get at the type library which drives
+			                 -- the dispatch interface.)
+		              -- -> IO (IDispatch ()) 
+			                 -- the dispatch implementation handed back.
+
+	, VTable
+	, ComVTable
+	, PrimIP
+
+	, ComInterface
+	, mkIface
+	, mkDispIface
+	, mkDualIface
+	
+	, export_getTypeInfoCount
+	, export_getTypeInfo
+	, export_getIDsOfNames
+	, export_invoke
+	) where
+
+import HDirect
+import Word
+import Int
+import IOExts
+import Com     hiding ( queryInterface, addRef, release )
+import qualified Com ( addRef, release )
+import Automation ( IDispatch, VARIANT, iidIDispatch, DISPID )
+import Foreign.StablePtr
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.Storable
+import Maybe   ( fromMaybe )
+import Bits ( (.&.) )
+import ComException
+import WideString
+
+import Monad
+import List
+\end{code}
+
+Basic types - we're essentially untyped here; safety is provided
+by the abstraction levels above us.
+
+\begin{code}
+type PrimIP iid   = Ptr (Ptr ())
+type VTBL	  = (Ptr (Ptr ()), Int)
+type VTable    iid objState = VTBL
+type ComVTable iid objState = VTable iid (objState, IUnkState)
+
+data ComInterface objState 
+  = Iface     { ifaceGUID :: GUID
+              , ifaceVTBL  :: VTBL
+	      }
+  | DispIface { ifaceGUID  :: GUID
+	      , ifaceLIBID :: Either LIBID String
+	      , ifaceVTBL  :: VTBL
+	      , isDual     :: Bool
+	      }
+
+mkIface :: IID iid -> VTable iid objState -> ComInterface objState
+mkIface iid a = Iface (iidToGUID iid) a
+
+mkDispIface :: Maybe LIBID -> IID iid -> VTable iid objState -> ComInterface objState
+mkDispIface l iid v = DispIface (iidToGUID iid) l' v False
+ where
+  l' = fromMaybe (Right "") (fmap Left l)
+
+mkDualIface :: Maybe LIBID -> IID iid -> VTable iid objState -> ComInterface objState
+mkDualIface l iid v = DispIface (iidToGUID iid) l' v True
+ where
+  l' = fromMaybe (Right "") (fmap Left l)
+
+\end{code}
+
+=== Creating a component instance ===
+
+`createComInstance' creates a new COM component instance, given
+the initial state together with the (implementation) of the
+interfaces that the component supports. The interface pointer
+that it returns is at the one requested.
+
+\begin{code}
+createComInstance :: String                   -- DLL path.
+                  -> objState		      -- initial state
+		  -> IO ()                    -- action to perform when releasing object.
+	          -> [ComInterface objState]  -- supported interfaces
+	          -> IID (IUnknown iid)
+	          -> IO (IUnknown iid)
+createComInstance dll_path initState releaseAction supported_ifaces initial_iid = do
+  ip_state  <- mkInstanceState supported_ifaces dll_path releaseAction initState
+  (_,iu)    <- deRefStablePtr  ip_state
+  res	    <- lookupInterface initial_iid (iu_ifaces iu)
+  case res of
+    (_,_,ip) -> do
+--       putMessage ("createComInstance: " ++ show initial_iid)
+       return (castIface ip)
+
+createInstance :: objState -> VTable (IUnknown iid) objState  -> IO (IUnknown iid)
+createInstance initState vtable = do
+  ip_state     <- newStablePtr initState
+  createIPointer ip_state vtable
+
+\end{code}
+
+=== Creating the component instance specific state ===
+
+Internal function which allocates an (immovable) chunk of
+memory which holds the instance-specific state of a component.
+For each component instance we keep a stable pointer to the
+component instance state. In all likelihood, this object state
+also contains enough information for the <tt/IUnknown/ methods
+to operate correctly.
+
+\begin{code}
+createIPointer :: StablePtr a
+	       -> VTBL
+	       -> IO (IUnknown b)
+createIPointer iface_st (vtbl,_) = do
+   pre   <- alloc (sizeofIfaceHeader)
+   poke pre vtbl
+   poke (pre `plusPtr` fromIntegral sizeofPtr) iface_st
+--   writeAddrOffAddr      pre 0 vtbl
+--   writeStablePtrOffAddr pre 1 iface_st
+   unmarshallIUnknown False{-finalise-} pre
+
+sizeofIfaceHeader :: Word32  -- in bytes.
+sizeofIfaceHeader =
+       sizeofPtr  -- lpVtbl
+   +   sizeofPtr  -- interface pointer state
+
+-- for convenience.
+cloneIPointer :: IUnknown iid_old -> VTable (IUnknown iid_new) objState -> IO (IUnknown iid_new)
+cloneIPointer iptr vtbl = do
+  stable_state <- getIPointerState_stbl (ifaceToAddr iptr)
+  createIPointer stable_state vtbl
+
+cloneIPointer_prim :: Ptr (IUnknown a) -> VTable (IUnknown iid_new) objState -> IO (IUnknown iid_new)
+cloneIPointer_prim iptr vtbl = do
+  stable_state <- getIPointerState_stbl iptr
+  createIPointer stable_state vtbl
+\end{code}
+
+<tt/findInterface/ is used by both the class factory
+and <tt/queryInterface/ to check whether the component
+implements a particular interface.
+
+\begin{code}
+findInterface :: IUnkIfaceInfo
+	      -> Ptr GUID
+	      -> Ptr (Ptr (IUnknown b))
+	      -> IO HRESULT
+findInterface ls piid ppv = do
+    iid		 <- unmarshallGUID False piid
+    if (iid == iidToGUID iidIUnknown) then 
+      case ls of
+        []	      -> return e_NOINTERFACE
+	((_,_,ip):_)  -> realiseIPointer ip
+     else if (iid == iidToGUID iidIDispatch) then
+      case filter (isIDispatch) ls of
+         []	      -> return e_NOINTERFACE
+	 ((_,_,ip):_) -> realiseIPointer ip
+
+     else
+      let
+       findIt [] = do
+         poke (castPtr ppv) nullPtr
+         return e_NOINTERFACE
+       findIt ((x,_,ip):xs)
+         | x == iid  = realiseIPointer ip
+         | otherwise = findIt xs
+      in
+      findIt ls
+  where
+    -- 'realiseIPointer' fills in the [out] ptr and return.
+    -- This has the desired effect of forcing the evaluation
+    -- of the interface pointer itself.
+   realiseIPointer newip = do
+      primip <- marshallIUnknown newip
+      writefptr ppv primip
+--      writeForeignObj ppv primip
+      addRef (ifaceToAddr newip)
+      return s_OK
+
+    -- 
+    -- Note: there's currently no way of indicating that
+    -- an interface IA (which derives from IDispatch) has
+    -- a 'idispatch' nature here other than go via the
+    -- route of using the tlb marshaller.
+    -- 
+   isIDispatch (iid, flg, _) = flg || iid == iidToGUID iidIDispatch
+
+lookupInterface :: IID iid 
+		-> IUnkIfaceInfo -- [(GUID, Bool, IUnknown ())]
+		-> IO (GUID, Bool, IUnknown ())
+lookupInterface iid []       = ioError (userError "lookupInterface: interface not supported")
+lookupInterface iid ls@(i:_) =
+  case (find (\ (i,_,_) -> i == guid) ls) of
+    Nothing   -> return i
+    Just i    -> return i
+ where
+  guid = iidToGUID iid
+
+\end{code}
+
+\begin{code}
+data IUnkState
+ = IUnkState
+     { iu_ifaces   :: IUnkIfaceInfo
+     , iu_release  :: IO ()
+     , iu_refcnt   :: IORef Int
+     }
+
+type IUnkIfaceInfo = [(GUID, Bool, IUnknown ())]
+
+mkInstanceState :: [ComInterface objState] 
+                -> String
+		-> IO ()
+                -> objState
+		-> IO (StablePtr (objState, IUnkState))
+mkInstanceState iface_list dll_path releaseAction objState = do
+  fixIO (\ stbl_st -> do
+     ref_cnt <- newIORef 1
+     let iptrs = map (mkIf stbl_st) iface_list
+         iu_st = IUnkState iptrs releaseAction ref_cnt
+     newStablePtr (objState, iu_st)
+   )
+ where
+  mkIf st (Iface iid vtbl)              = 
+     (iid, False, unsafePerformIO (createIPointer st vtbl))
+  mkIf st (DispIface guid libid vtbl is_dual) =
+     (guid, True, unsafePerformIO $ do 
+		    let iid     = guidToIID guid
+		        lib_loc = 
+			  case libid of
+			    Right "" -> Right dll_path
+			    _        -> libid
+		    if is_dual then 
+		       createDualInterface st vtbl lib_loc iid
+		     else do
+   		       ip <- createIPointer st vtbl
+		       createDispInterface ip lib_loc iid
+     )
+\end{code}
+
+'Standard' IUnknown implementation:
+
+Implementation assumes that the object state is of
+the form :
+
+   StablePtr ((real_obj_state::a), (iu_state :: IUnkState))
+
+(which it is if 'createCoClass' was used to create the component
+instance.)
+
+\begin{code}
+queryInterface :: Ptr (IUnknown a)
+	       -> Ptr GUID
+	       -> Ptr (Ptr (IUnknown b))
+	       -> IO HRESULT
+queryInterface iptr riid ppvObject = do
+  iid		 <- unmarshallGUID False riid
+--  putMessage ("qi: " ++ show (iptr,iid))
+  if_ls <- getSupportedInterfaces iptr
+  hr    <- findInterface if_ls riid ppvObject
+--  putMessage ("qi: " ++ show (iid,hr))
+  return hr
+
+addRef :: Ptr (IUnknown a) -> IO Word32
+addRef iptr = do
+--   putMessage "addRef"
+   v <- readRefCount iptr
+   writeRefCount iptr (v+1)
+   return (fromIntegral v)
+
+release :: Ptr (IUnknown a) -> IO Word32
+release iptr = do
+--   putMessage ("release: " ++ show iptr)
+   v <- readRefCount iptr
+--   putMessage ("release: " ++ show (iptr,v))
+   let v' = v-1
+   writeRefCount iptr v'
+   if v' <= 0 then do
+      releaseObj iptr
+      let x = (fromIntegral 0) 
+      return x
+    else do
+      let x = (fromIntegral (v-1))
+      return x
+
+\end{code}
+
+\begin{code}
+foreign export stdcall dynamic  export_queryInterface :: (Ptr (IUnknown a) -> Ptr GUID -> Ptr (Ptr (IUnknown b)) -> IO Int32) -> IO (Ptr ())
+foreign export stdcall dynamic  export_addRef  :: (Ptr (IUnknown a) -> IO Word32) -> IO (Ptr ())
+foreign export stdcall dynamic  export_release :: (Ptr (IUnknown a) -> IO Word32) -> IO (Ptr ())
+\end{code}
+
+\begin{code}
+releaseObj :: Ptr (IUnknown a) -> IO ()
+releaseObj iptr = do
+--   putMessage "releaseObj"
+     -- * invoke user-supplied finaliser.
+   r <- iptr # getReleaseAction
+   r
+   -- * free up mem allocated to hold interface pointers (and vtbls?).
+   -- * free embedded stable pointers.
+   stbl <- iptr # getIPointerState_stbl
+   freeStablePtr stbl
+    -- and the GC will take care of the rest..   
+   return ()
+
+\end{code}
+
+Accessing data accessible via a Haskell i-pointer - this stuff
+
+\begin{code}
+readRefCount :: Ptr (IUnknown a) -> IO Int
+readRefCount ptr = do
+  iu <- getIUnkState ptr
+  readIORef (iu_refcnt iu)
+
+writeRefCount :: Ptr (IUnknown a) -> Int -> IO ()
+writeRefCount ptr v = do
+  iu <- getIUnkState ptr
+  writeIORef (iu_refcnt iu) v
+
+getReleaseAction :: Ptr (IUnknown a) -> IO (IO ())
+getReleaseAction ptr = do
+  iu <- getIUnkState ptr
+  return (iu_release iu)
+
+getSupportedInterfaces :: Ptr (IUnknown a)  -> IO IUnkIfaceInfo
+getSupportedInterfaces ptr = do
+  iu_state <- getIUnkState ptr
+  return (iu_ifaces iu_state)
+
+getIUnkState :: Ptr (IUnknown a) -> IO IUnkState
+getIUnkState iptr = do
+  stbl  <- getIPointerState_stbl iptr
+  (_,x) <- deRefStablePtr stbl
+  return x
+
+-- users of 'createCoClass' *must* use this and not
+-- the one below!
+getObjState :: Ptr (IUnknown a) -> IO b
+getObjState iptr = do
+  stbl  <- getIPointerState_stbl iptr
+  (x,_) <- deRefStablePtr stbl
+  return x
+
+getRealObjState :: Ptr (IUnknown a) -> IO b
+getRealObjState iptr = do
+  stbl  <- getIPointerState_stbl iptr
+  deRefStablePtr stbl
+
+getIPointerState_stbl :: Ptr (IUnknown a) -> IO (StablePtr b)
+getIPointerState_stbl iptr = peek (iptr `plusPtr` fromIntegral sizeofPtr)
+--readStablePtrOffAddr iptr 1
+
+\end{code}
+
+Dispatch interface support:
+
+\begin{code}
+createDualInterface :: StablePtr objState
+		    -> ComVTable (IUnknown iid) objState
+		    -> Either LIBID String
+		    -> IID (IUnknown iid)
+		    -> IO (IUnknown iid)
+createDualInterface ip_state vtbl libid iid = do
+    ip     <- createIPointer ip_state vtbl
+    st     <- mkDispatchState libid ip iid
+    meths  <- unmarshallVTable vtbl
+    let real_meths = 
+	    case meths of
+	      (qi : ar : re : ls) -> ls
+	      _			  -> error "createDualInterface: failed to strip of IU methods"
+    vtable <- createDispVTable real_meths st 
+    cloneIPointer ip vtable
+
+createDispInterface :: IUnknown iid   -- the interface to delegate to
+		    -> Either LIBID String
+			   -- libid of type library to use / path to where the .tlb is stored.
+		    -> IID (IUnknown iid)
+		           -- what interface it implements (needed to
+			   -- get at the type library which drives
+			   -- the dispatch interface.)
+		    -> IO (IUnknown iid)
+			   -- the dispatch implementation handed back.
+createDispInterface ip libid iid = do
+--    putMessage ("createDispInterface: " ++ show (libid, iid))
+    st     <- mkDispatchState libid ip iid
+--    putMessage ("createDispInterface: " ++ show (libid, iid))
+    vtable <- createDispVTable [] st
+--    putMessage ("createDispInterface: " ++ show (libid, iid))
+    i <- cloneIPointer ip vtable
+--    putMessage ("createDispInterface: " ++ show (libid, iid))
+    return i
+
+mkDispatchState :: Either LIBID String
+		-> IUnknown iid
+		-> IID (IUnknown iid)
+		-> IO DispState
+mkDispatchState libid ip iid = do
+   pTInfo_ref <- newIORef nullPtr
+   return (DispState libid (coerceIID iid) (coerceIP ip) pTInfo_ref)
+
+--sigh.
+coerceIID :: IID a -> IID b
+coerceIID iid = guidToIID (iidToGUID iid)
+
+coerceIP :: IUnknown a -> IUnknown b
+coerceIP x = castIface x
+
+data DispState
+ = DispState {
+       disp_libid :: Either LIBID String,
+       disp_iid   :: (IID ()),
+       disp_ip    :: (IUnknown ()),
+       disp_ti    :: (IORef (PrimIP (ITypeInfo ())))
+   }
+
+type DISPPARAMS = Ptr () -- abstract, really.
+type EXCEPINFO  = Ptr () -- abstract, really.
+
+createDispVTable :: [Ptr ()] 
+	         -> DispState
+		 -> IO (ComVTable (IDispatch ()) DispState)
+createDispVTable meths disp_st = do
+  a_getTypeInfoCount <- export_getTypeInfoCount getTypeInfoCount
+  a_getTypeInfo	     <- export_getTypeInfo      (getTypeInfo disp_st)
+  a_getIDsOfNames    <- export_getIDsOfNames	(getIDsOfNames disp_st)
+  a_invoke	     <- export_invoke		(invoke disp_st)
+  createComVTable ([ a_getTypeInfoCount
+		   , a_getTypeInfo
+		   , a_getIDsOfNames
+		   , a_invoke
+		   ] ++ meths)
+
+getTypeInfoCount :: Ptr () -> Ptr Word32 -> IO HRESULT
+getTypeInfoCount iptr pctInfo = do
+--  putMessage "getTypeInfoCount"
+  writeWord32 pctInfo 1
+  return s_OK
+
+foreign export stdcall dynamic export_getTypeInfoCount
+	    :: (Ptr () -> Ptr Word32 -> IO HRESULT) -> IO (Ptr ())
+
+getTypeInfo :: DispState -> Ptr (IDispatch ()) -> Word32 -> LCID -> Ptr () -> IO HRESULT
+getTypeInfo disp_state this iTInfo lcid ppTInfo
+  | iTInfo /= 0         = return tYPE_E_ELEMENTNOTFOUND
+  | ppTInfo == nullPtr  = return e_POINTER
+  | otherwise		= do
+--  putMessage "getTypeInfo"
+  poke (castPtr ppTInfo) nullPtr
+  let ppITInfo_ref = disp_ti disp_state
+  (hr, pITInfo) <- do
+    pITInfo     <- readIORef ppITInfo_ref
+     -- load up the typelib is done the first time
+     -- around. Cannot do it earlier (or lazily), since
+     -- loading is dependent on the 'lcid'.
+     --
+     -- The caching of the ITypeInfo* only works because
+     -- we keep a disp_state for each interface.
+    if (pITInfo == nullPtr) then do
+       ppITInfo <- allocOutPtr
+       hr       <- loadTypeInfo (disp_libid disp_state) (disp_iid disp_state) lcid ppITInfo
+--       putMessage ("getTypeInfo: " ++ show hr)
+       if (failed hr) then
+          return (hr, undefined)
+        else do
+         pITInfo  <- peek ppITInfo
+         writeIORef ppITInfo_ref pITInfo
+         return (s_OK, pITInfo)
+     else
+       return (s_OK, pITInfo)
+
+    -- do an AddRef() since we're handing out a copy to it.
+    -- => when the GetIDsOfNames() and Invoke() implementations
+    --    below call getTypeInfo, they'll have to call Release()
+    --    when finished with the result here.
+    --
+  if (failed hr) then
+      return hr
+   else do
+     punk <- unmarshallIUnknown True{-addRef and finalise-} pITInfo
+       -- to counter the effect of running the finaliser on pITInfo.
+     Com.addRef punk
+     poke (castPtr ppTInfo) pITInfo
+     return s_OK
+
+-- Loading the type info is lcid sensitive, so we
+-- have to manually invoke this from within GetTypeInfo()
+loadTypeInfo :: Either LIBID String
+	     -> IID iid
+	     -> LCID
+	     -> Ptr (PrimIP (ITypeInfo ()))
+	     -> IO HRESULT
+loadTypeInfo tlb_loc iid lcid ppITI = do
+   (hr, pITypeLib) <- 
+    catch
+     (case tlb_loc of
+        Left libid -> do
+	   ip <- loadRegTypeLib libid 1 0 (fromIntegral (primLangID lcid))
+	   return (s_OK, ip)
+	  -- load it in silently
+        Right path -> do
+           ip <- loadTypeLibEx path False{-don't register-}
+	   return (s_OK, ip))
+     (\ ex -> do
+     	 putMessage "Failed to load typelib"
+         return (fromMaybe e_FAIL (coGetErrorHR ex), interfaceNULL))
+   if (failed hr) then
+      return hr
+    else do
+      hr <- pITypeLib # getTypeInfoOfGuid iid ppITI
+        -- pITypeLib is a finalised i-pointer, and will be
+	-- released in due course.
+	-- NOTE: potential bug farm.
+      return hr
+
+-- from oleauto.h
+foreign import ccall "primLoadRegTypeLib" 
+  primLoadRegTypeLib :: Ptr () -> Word16 -> Word16 -> Word32 -> Ptr () -> IO HRESULT
+
+foreign export stdcall dynamic export_getTypeInfo
+	    :: (Ptr (IDispatch ()) -> Word32 -> LCID -> Ptr () -> IO HRESULT) -> IO (Ptr ())
+
+getIDsOfNames :: DispState
+	      -> Ptr (IDispatch ())
+	      -> Ptr (IID ())
+	      -> Ptr WideString
+	      -> Word32
+	      -> LCID
+	      -> Ptr DISPID
+	      -> IO HRESULT
+getIDsOfNames disp_state this riid rgszNames cNames lcid rgDispID = do
+--    putMessage ("getIDs: " ++ show cNames)
+    pti      <- allocOutPtr
+    hr       <- getTypeInfo disp_state this 0 lcid pti
+    if (failed hr) then do
+       free pti
+       return hr
+     else do
+       prim_ti <- peek (castPtr pti)
+       free pti
+--       pw      <- peek (castPtr rgszNames)
+       hr      <- prim_ti # getIDsOfNamesTI rgszNames cNames rgDispID
+       return hr
+
+foreign export stdcall dynamic export_getIDsOfNames
+	    :: (Ptr (IDispatch ()) -> Ptr (IID ()) -> Ptr WideString -> Word32 -> LCID -> Ptr DISPID -> IO HRESULT) -> IO (Ptr ())
+
+invoke :: DispState
+       -> Ptr (IDispatch ())
+       -> DISPID
+       -> Ptr (IID a)
+       -> LCID
+       -> Word32
+       -> Ptr DISPPARAMS
+       -> Ptr VARIANT
+       -> Ptr EXCEPINFO
+       -> Ptr Word32
+       -> IO HRESULT
+invoke disp_state this dispIdMember riid lcid wFlags pDispParams pVarResult pExcepInfo puArgErr = do
+   iid <- unmarshallIID False riid
+--   putMessage ("invoke: " ++ show (dispIdMember, iid))
+   if (iid /= castIID iidNULL) then
+      return dISP_E_UNKNOWNINTERFACE
+    else do
+      pti      <- allocOutPtr
+      hr       <- getTypeInfo disp_state this 0 lcid pti
+      if (failed hr) then do
+         free pti
+         return hr
+       else do
+        prim_ti  <- peek (castPtr pti)
+        let ip = disp_ip disp_state
+	  -- hand over to the typelib marshaller, but making sure that
+	  -- any exceptions within the user code will be handled correctly.
+        clearException
+        hr <- prim_ti # invokeTI ip dispIdMember wFlags pDispParams pVarResult pExcepInfo puArgErr
+        fillException pExcepInfo lcid
+	ip <- unmarshallIUnknown False prim_ti
+	ip # Com.release
+        return hr
+
+invokeTI :: IUnknown a
+	 -> DISPID
+	 -> Word32
+	 -> Ptr DISPPARAMS
+	 -> Ptr VARIANT
+	 -> Ptr EXCEPINFO
+	 -> Ptr Word32
+	 -> Ptr (ITypeInfo a)
+	 -> IO HRESULT
+invokeTI ip dispIdMember wFlags pDispParams pVarResult pExcepInfo puArgErr this = do
+  iptr_fo <- marshallIUnknown ip
+  let offset    = (11::Int)
+  lpVtbl  <- peek (castPtr this)
+  methPtr <- indexPtr lpVtbl offset
+  withForeignPtr iptr_fo $ \ iptr -> 
+    prim_invokeTI methPtr (castPtr this) iptr dispIdMember wFlags pDispParams pVarResult pExcepInfo puArgErr
+
+foreign import stdcall dynamic
+  prim_invokeTI :: Ptr (ITypeInfo a) -> Ptr () -> Ptr () -> DISPID -> Word32 
+                -> Ptr DISPPARAMS -> Ptr VARIANT -> Ptr EXCEPINFO -> Ptr Word32 -> IO HRESULT
+
+getTypeInfoOfGuid :: IID iid -> Ptr (PrimIP (ITypeInfo ())) -> IUnknown a -> IO HRESULT
+getTypeInfoOfGuid iid ppITI this = do
+  let offset = (6::Int)
+  pthis   <- marshallIUnknown this
+  let a = foreignPtrToPtr pthis
+  lpVtbl  <- peek (castPtr a)
+  methPtr <- indexPtr lpVtbl offset
+  piid	  <- marshallIID iid
+  withForeignPtr pthis $ \ pthis -> 
+   withForeignPtr piid  $ \ piid -> 
+    prim_getTypeInfoOfGuid methPtr pthis piid ppITI
+
+foreign import stdcall dynamic
+  prim_getTypeInfoOfGuid :: Ptr () -> Ptr (Ptr a)
+  			 -> Ptr (IID iid) -> Ptr (PrimIP (ITypeInfo ())) -> IO HRESULT
+
+getIDsOfNamesTI :: Ptr WideString -> Word32 -> Ptr DISPID -> Ptr (ITypeInfo ()) -> IO HRESULT
+getIDsOfNamesTI rgszNames cNames rgDispID this = do
+  let offset = (10::Int)
+  lpVtbl  <- peek (castPtr this)
+  methPtr <- indexPtr lpVtbl offset
+  prim_getIDsOfNamesTI methPtr (castPtr this) rgszNames cNames rgDispID
+
+foreign import stdcall dynamic
+  prim_getIDsOfNamesTI :: Ptr (ITypeInfo ()) -> Ptr () -> Ptr WideString -> Word32 -> Ptr DISPID -> IO HRESULT
+
+clearException :: IO ()
+clearException = return ()
+
+fillException :: Ptr EXCEPINFO
+	      -> LCID
+	      -> IO ()
+fillException _ _ = return ()
+	      
+
+foreign export stdcall dynamic export_invoke
+   :: (Ptr (IDispatch ()) -> DISPID -> Ptr (IID a) -> LCID -> Word32 -> Ptr DISPPARAMS
+   -> Ptr VARIANT -> Ptr EXCEPINFO -> Ptr Word32 -> IO HRESULT) -> IO (Ptr ())
+
+data TypeInfo  a = TypeInfo__
+type ITypeInfo a = IUnknown (TypeInfo a)
+
+--makeLangID :: Word16 -> Word16 -> Word16
+--makeLangID p s = (shiftL p 10) .|. s
+
+primLangID :: Word32 -> Word32
+primLangID w = (w .&. 0x3ff)
+\end{code}
+
+Manufacturing method tables out of a list of method pointers.
+
+\begin{code}
+createVTable :: [Ptr ()] -> IO (VTable iid objState)
+createVTable methods = do
+  vtbl <- alloc (sizeofPtr * fromIntegral no_meths)
+  sequence (zipWith (pokeElemOff vtbl) [(0::Int)..] methods)
+  return (vtbl, no_meths)
+ where
+  no_meths = length methods
+
+unmarshallVTable :: VTable iid objState -> IO [Ptr ()]
+unmarshallVTable (vtbl, no_meths) =
+  mapM (peekElemOff vtbl) [(0::Int)..no_meths]
+
+createComVTable :: [Ptr ()] -> IO (ComVTable iid objState)
+createComVTable methods = do
+  m_queryInterface <- export_queryInterface queryInterface
+  m_addRef         <- export_addRef  addRef
+  m_release        <- export_release release
+  createVTable (m_queryInterface: m_addRef: m_release: methods)
+
+\end{code}
+ comlib/Connection.hs view
@@ -0,0 +1,275 @@+-- Automatically generated by HaskellDirect (ihc.exe), version 0.20
+-- Created: 20:13 Pacific Standard Time, Tuesday 16 December, 2003
+-- Command line: -fno-qualified-names -fappend-interface-short-name -c Connection.idl -o Connection.hs
+
+module Connection
+       ( DWORD
+       , ULONG
+       , PCONNECTIONPOINT
+       , LPCONNECTIONPOINT
+       , getConnectionInterface
+       , getConnectionPointContainer
+       , advise
+       , unadvise
+       , enumConnections
+       , IConnectionPoint
+       , IConnectionPoint_
+       , iidIConnectionPoint
+       , PCONNECTIONPOINTCONTAINER
+       , LPCONNECTIONPOINTCONTAINER
+       , enumConnectionPoints
+       , findConnectionPoint
+       , IConnectionPointContainer
+       , IConnectionPointContainer_
+       , iidIConnectionPointContainer
+       , PENUMCONNECTIONS
+       , LPENUMCONNECTIONS
+       , CONNECTDATA(..)
+       , writeCONNECTDATA
+       , readCONNECTDATA
+       , sizeofCONNECTDATA
+       , TagCONNECTDATA
+       , PCONNECTDATA0
+       , TagCONNECTDATA0
+       , LPCONNECTDATA0
+       , next
+       , skip
+       , reset
+       , clone
+       , IEnumConnections
+       , IEnumConnections_
+       , iidIEnumConnections
+       , PENUMCONNECTIONPOINTS
+       , LPENUMCONNECTIONPOINTS
+       , nextECP
+       , skipECP
+       , resetECP
+       , cloneECP
+       , IEnumConnectionPoints
+       , IEnumConnectionPoints_
+       , iidIEnumConnectionPoints
+       ) where
+       
+import Prelude
+import Com (IUnknown, IID, mkIID, sizeofIID, invokeAndCheck, 
+            unmarshallIID, readIUnknown, marshallIUnknown, marshallIID, 
+            writeIUnknown, enumNext, enumSkip, enumReset, enumClone)
+import Foreign.ForeignPtr (withForeignPtr)
+import Foreign.Ptr (Ptr)
+import HDirect (allocBytes, sizeofForeignPtr, free, doThenFree, 
+                sizeofWord32, readWord32, writeWord32, addNCastPtr)
+import Int (Int32)
+import Word (Word32)
+
+type DWORD = Word32
+type ULONG = Word32
+-- --------------------------------------------------
+-- 
+-- interface IConnectionPoint
+-- 
+-- --------------------------------------------------
+data IConnectionPoint_ a = IConnectionPoint__
+                             
+type IConnectionPoint a = IUnknown (IConnectionPoint_ a)
+iidIConnectionPoint :: IID (IConnectionPoint ())
+iidIConnectionPoint =
+  mkIID "{B196B286-BAB4-101A-B69C-00AA00341D07}"
+
+type PCONNECTIONPOINT = IConnectionPoint ()
+type LPCONNECTIONPOINT = IConnectionPoint ()
+getConnectionInterface :: IConnectionPoint a0
+                       -> IO (IID ())
+getConnectionInterface iptr =
+  do
+    piid <- allocBytes (fromIntegral sizeofIID)
+    invokeAndCheck (\ methPtr iptr -> prim_Connection_getConnectionInterface methPtr iptr piid) 3 iptr
+    unmarshallIID True piid
+
+foreign import stdcall "dynamic" prim_Connection_getConnectionInterface :: Ptr () -> Ptr () -> Ptr (IID a) -> IO Int32
+getConnectionPointContainer :: IConnectionPoint a0
+                            -> IO (IConnectionPointContainer ())
+getConnectionPointContainer iptr =
+  do
+    ppCPC <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_Connection_getConnectionPointContainer methPtr iptr ppCPC) 4 iptr
+    doThenFree free (readIUnknown False) ppCPC
+
+foreign import stdcall "dynamic" prim_Connection_getConnectionPointContainer :: Ptr () -> Ptr () -> Ptr (Ptr (IConnectionPointContainer a)) -> IO Int32
+advise :: IUnknown a1
+       -> IConnectionPoint a0
+       -> IO DWORD
+advise pUnkSink iptr =
+  do
+    pdwCookie <- allocBytes (fromIntegral sizeofWord32)
+    pUnkSink <- marshallIUnknown pUnkSink
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr pUnkSink (\ pUnkSink -> prim_Connection_advise methPtr iptr pUnkSink pdwCookie)) 5 iptr
+    doThenFree free readWord32 pdwCookie
+
+foreign import stdcall "dynamic" prim_Connection_advise :: Ptr () -> Ptr () -> Ptr (IUnknown a) -> Ptr Word32 -> IO Int32
+unadvise :: DWORD
+         -> IConnectionPoint a0
+         -> IO ()
+unadvise dwCookie iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_Connection_unadvise methPtr iptr dwCookie)
+                 6
+                 iptr
+
+foreign import stdcall "dynamic" prim_Connection_unadvise :: Ptr () -> Ptr () -> Word32 -> IO Int32
+enumConnections :: IConnectionPoint a0
+                -> IO (IEnumConnections ())
+enumConnections iptr =
+  do
+    ppEnum <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_Connection_enumConnections methPtr iptr ppEnum) 7 iptr
+    doThenFree free (readIUnknown False) ppEnum
+
+foreign import stdcall "dynamic" prim_Connection_enumConnections :: Ptr () -> Ptr () -> Ptr (Ptr (IEnumConnections a)) -> IO Int32
+-- --------------------------------------------------
+-- 
+-- interface IConnectionPointContainer
+-- 
+-- --------------------------------------------------
+data IConnectionPointContainer_ a = IConnectionPointContainer__
+                                      
+type IConnectionPointContainer a = IUnknown (IConnectionPointContainer_ a)
+iidIConnectionPointContainer :: IID (IConnectionPointContainer ())
+iidIConnectionPointContainer =
+  mkIID "{B196B284-BAB4-101A-B69C-00AA00341D07}"
+
+type PCONNECTIONPOINTCONTAINER = IConnectionPointContainer ()
+type LPCONNECTIONPOINTCONTAINER = IConnectionPointContainer ()
+enumConnectionPoints :: IConnectionPointContainer a0
+                     -> IO (IEnumConnectionPoints ())
+enumConnectionPoints iptr =
+  do
+    ppEnum <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_Connection_enumConnectionPoints methPtr iptr ppEnum) 3 iptr
+    doThenFree free (readIUnknown False) ppEnum
+
+foreign import stdcall "dynamic" prim_Connection_enumConnectionPoints :: Ptr () -> Ptr () -> Ptr (Ptr (IEnumConnectionPoints a)) -> IO Int32
+findConnectionPoint :: IID a1
+                    -> IConnectionPointContainer a0
+                    -> IO (IConnectionPoint ())
+findConnectionPoint riid iptr =
+  do
+    ppCP <- allocBytes (fromIntegral sizeofForeignPtr)
+    riid <- marshallIID riid
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr riid (\ riid -> prim_Connection_findConnectionPoint methPtr iptr riid ppCP)) 4 iptr
+    doThenFree free (readIUnknown False) ppCP
+
+foreign import stdcall "dynamic" prim_Connection_findConnectionPoint :: Ptr () -> Ptr () -> Ptr (IID a) -> Ptr (Ptr (IConnectionPoint a)) -> IO Int32
+-- --------------------------------------------------
+-- 
+-- interface IEnumConnections
+-- 
+-- --------------------------------------------------
+data IEnumConnections_ a = IEnumConnections__
+                             
+type IEnumConnections a = IUnknown (IEnumConnections_ a)
+iidIEnumConnections :: IID (IEnumConnections ())
+iidIEnumConnections =
+  mkIID "{B196B287-BAB4-101A-B69C-00AA00341D07}"
+
+type PENUMCONNECTIONS = IEnumConnections ()
+type LPENUMCONNECTIONS = IEnumConnections ()
+data CONNECTDATA = TagCONNECTDATA {pUnk :: (IUnknown ()),
+                                   dwCookie :: DWORD}
+                     
+writeCONNECTDATA :: Bool
+                 -> Ptr CONNECTDATA
+                 -> CONNECTDATA
+                 -> IO ()
+writeCONNECTDATA addRefMe__ ptr (TagCONNECTDATA pUnk dwCookie) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeIUnknown addRefMe__ pf1 pUnk
+    let pf2 = addNCastPtr pf1 4
+    writeWord32 pf2 dwCookie
+
+readCONNECTDATA :: Bool
+                -> Ptr CONNECTDATA
+                -> IO CONNECTDATA
+readCONNECTDATA finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    pUnk <- readIUnknown finaliseMe__ pf1
+    let pf2 = addNCastPtr pf1 4
+    dwCookie <- readWord32 pf2
+    return (TagCONNECTDATA pUnk dwCookie)
+
+sizeofCONNECTDATA :: Word32
+sizeofCONNECTDATA = 8
+
+type TagCONNECTDATA = CONNECTDATA
+type PCONNECTDATA0 = TagCONNECTDATA
+type TagCONNECTDATA0 = CONNECTDATA
+type LPCONNECTDATA0 = TagCONNECTDATA0
+next :: ULONG
+     -> IEnumConnections a0
+     -> IO [CONNECTDATA]
+next cConnections iptr =
+  enumNext sizeofCONNECTDATA
+           (readCONNECTDATA False)
+           cConnections
+           iptr
+
+skip :: ULONG
+     -> IEnumConnections a0
+     -> IO ()
+skip cConnections iptr =
+  enumSkip cConnections
+           iptr
+
+reset :: IEnumConnections a0
+      -> IO ()
+reset iptr = enumReset iptr
+
+clone :: IEnumConnections a0
+      -> IO (IEnumConnections ())
+clone iptr = enumClone iptr
+
+-- --------------------------------------------------
+-- 
+-- interface IEnumConnectionPoints
+-- 
+-- --------------------------------------------------
+data IEnumConnectionPoints_ a = IEnumConnectionPoints__
+                                  
+type IEnumConnectionPoints a = IUnknown (IEnumConnectionPoints_ a)
+iidIEnumConnectionPoints :: IID (IEnumConnectionPoints ())
+iidIEnumConnectionPoints =
+  mkIID "{B196B285-BAB4-101A-B69C-00AA00341D07}"
+
+type PENUMCONNECTIONPOINTS = IEnumConnectionPoints ()
+type LPENUMCONNECTIONPOINTS = IEnumConnectionPoints ()
+nextECP :: ULONG
+        -> IEnumConnectionPoints a0
+        -> IO [IConnectionPoint a1]
+nextECP cConnections iptr =
+  enumNext sizeofForeignPtr
+           (readIUnknown False)
+           cConnections
+           iptr
+
+skipECP :: ULONG
+        -> IEnumConnectionPoints a0
+        -> IO ()
+skipECP cConnections iptr =
+  enumSkip cConnections
+           iptr
+
+resetECP :: IEnumConnectionPoints a0
+         -> IO ()
+resetECP iptr = enumReset iptr
+
+cloneECP :: IEnumConnectionPoints a0
+         -> IO (IEnumConnectionPoints ())
+cloneECP iptr = enumClone iptr
+
+
+ comlib/Connection.idl view
@@ -0,0 +1,156 @@+/*
+ * Lifted out of objidl.idl, so that we can
+ * generate stubs for these separately.
+ *
+ */
+module Connection {
+
+// To make it self contained
+typedef unsigned long DWORD;
+typedef unsigned long ULONG;
+
+
+interface IConnectionPointContainer;
+interface IConnectionPoint;
+interface IEnumConnections;
+interface IEnumConnectionPoints;
+
+[
+    object,
+    uuid(B196B286-BAB4-101A-B69C-00AA00341D07),
+    pointer_default(unique)
+]
+interface IConnectionPoint : IUnknown
+{
+    typedef IConnectionPoint * PCONNECTIONPOINT;
+    typedef IConnectionPoint * LPCONNECTIONPOINT;
+
+    HRESULT GetConnectionInterface
+    (
+        [out]           IID * piid
+    );
+
+    HRESULT GetConnectionPointContainer
+    (
+        [out]           IConnectionPointContainer ** ppCPC
+    );
+
+    HRESULT Advise
+    (
+        [in]    IUnknown * pUnkSink,
+        [out]   DWORD *    pdwCookie
+    );
+
+    HRESULT Unadvise
+    (
+        [in]    DWORD dwCookie
+    );
+
+    HRESULT EnumConnections
+    (
+        [out]   IEnumConnections ** ppEnum
+    );
+}
+
+[
+    object,
+    uuid(B196B284-BAB4-101A-B69C-00AA00341D07),
+    pointer_default(unique)
+]
+interface IConnectionPointContainer : IUnknown
+{
+    typedef IConnectionPointContainer * PCONNECTIONPOINTCONTAINER;
+    typedef IConnectionPointContainer * LPCONNECTIONPOINTCONTAINER;
+
+    HRESULT EnumConnectionPoints
+    (
+        [out]   IEnumConnectionPoints ** ppEnum
+    );
+
+    HRESULT FindConnectionPoint
+    (
+        [in]    IID* riid,
+        [out]   IConnectionPoint ** ppCP
+    );
+}
+
+
+[
+    object,
+    uuid(B196B287-BAB4-101A-B69C-00AA00341D07),
+    pointer_default(unique)
+]
+interface IEnumConnections : IUnknown
+{
+    typedef IEnumConnections * PENUMCONNECTIONS;
+    typedef IEnumConnections * LPENUMCONNECTIONS;
+
+    typedef struct tagCONNECTDATA
+    {
+        IUnknown *  pUnk;
+        DWORD       dwCookie;
+    } CONNECTDATA;
+
+    typedef struct tagCONNECTDATA * PCONNECTDATA;
+    typedef struct tagCONNECTDATA * LPCONNECTDATA;
+
+    HRESULT Next(
+        [in]                        ULONG           cConnections,
+        [out,
+         size_is(cConnections),
+         length_is(*lpcFetched)]    CONNECTDATA *   rgcd,
+        [out]                       ULONG *         lpcFetched
+    );
+
+    HRESULT Skip
+    (
+        [in]    ULONG cConnections
+    );
+
+    HRESULT Reset
+    (
+        void
+    );
+
+    HRESULT Clone
+    (
+        [out]   IEnumConnections ** ppEnum
+    );
+}
+
+
+[
+    object,
+    uuid(B196B285-BAB4-101A-B69C-00AA00341D07),
+    pointer_default(unique)
+]
+interface IEnumConnectionPoints : IUnknown
+{
+    typedef IEnumConnectionPoints * PENUMCONNECTIONPOINTS;
+    typedef IEnumConnectionPoints * LPENUMCONNECTIONPOINTS;
+
+    HRESULT Next(
+        [in]                        ULONG               cConnections,
+        [out,
+         size_is(cConnections),
+         length_is(*lpcFetched)]    IConnectionPoint ** rgpcn,
+        [out]                       ULONG *             lpcFetched
+    );
+
+    HRESULT Skip
+    (
+        [in]    ULONG   cConnections
+    );
+
+    HRESULT Reset
+    (
+        void
+    );
+
+    HRESULT Clone
+    (
+        [out]   IEnumConnectionPoints **    ppEnum
+    );
+}
+
+};
+ comlib/ConnectionPoint.lhs view
@@ -0,0 +1,222 @@+%
+% (c), 1999 - sof
+%
+
+Generic implementation of COM connectable objects / connection points,
+server side.
+
+The connection between this framework impl. and the Haskell object
+responsible for firing events on the registered sinks, is still
+up in the air. The current arrangement is for the object and a
+particular connection point to share an IORef holding the current
+set of registered sinks. The object will then fire the events
+by using the (generated) stubs for that particular event interface.
+
+Probably want to abstract away the details of how sink broadcasting
+is done.
+
+\begin{code}
+module ConnectionPoint 
+		(
+		  mkConnectionContainer
+		) where
+
+import ComServ
+import Connection ( iidIConnectionPointContainer, iidIConnectionPoint,
+		    IConnectionPointContainer, IConnectionPoint,
+		    iidIEnumConnections, iidIEnumConnectionPoints
+		  )
+		    
+import Com
+import HDirect ( writeWord32, Ptr, sizeofPtr )
+import EnumInterface ( mkEnumInterface )
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.Storable
+import IOExts
+import Word
+import Int
+import ComException
+
+type ThisPtr = Ptr (IUnknown ())
+\end{code}
+
+
+\begin{code}
+mkConnectionContainer :: [(IID (IUnknown ()), IORef [(Word32, IUnknown ())])]
+                      -> IO (IConnectionPointContainer ())
+mkConnectionContainer ls = fixIO $ \ ip -> do
+  let ils = unsafePerformIO (mapM (mkConnection ip) ls)
+  addrOf_eCP <- export_enumCP (enumConnectionPoints (map snd ils))
+  addrOf_fCP <- export_fCP    (findConnectionPoint ils)
+  vtbl       <- createComVTable [ addrOf_eCP, addrOf_fCP ]
+  createComInstance "" () (return ())
+                    [mkIface iidIConnectionPointContainer vtbl]
+		    iidIConnectionPointContainer
+  
+mkConnection :: IConnectionPointContainer ()
+             -> (IID (IUnknown ()), IORef [(Word32, IUnknown ())])
+             -> IO (IID (IUnknown ()), IConnectionPoint ())
+mkConnection ip (iid, regd_sinks) = do
+  vtbl <- mkConnectionPointVTBL ip iid regd_sinks
+  ip   <- createComInstance "" () (return ())
+                            [ mkIface iidIConnectionPoint vtbl ]
+			    iidIConnectionPoint
+  return (iid, ip)
+
+\end{code}
+
+\begin{code}
+mkConnectionPointVTBL :: IConnectionPointContainer ()
+		      -> IID (IUnknown iid)
+                      -> IORef [(Word32, IUnknown ())]
+                      -> IO (ComVTable (IConnectionPoint a) objState)
+mkConnectionPointVTBL ip iid sinks = do
+   addrOf_gi    <- export_gi    (getConnectionInterface iid)
+   addrOf_gcpc  <- export_gcpc  (getConnectionPointContainer ip)
+   cookie_ref   <- newIORef (0::Word32)
+   addrOf_adv   <- export_adv   (advise sinks cookie_ref iid)
+   addrOf_unadv <- export_unadv (unadvise sinks)
+   addrOf_eC    <- export_eCP   (enumConnections sinks)
+   createComVTable
+         [ addrOf_gi , addrOf_gcpc , addrOf_adv, addrOf_unadv, addrOf_eC ]
+
+getConnectionInterface :: IID iid
+                       -> ThisPtr
+		       -> Ptr GUID
+		       -> IO HRESULT
+getConnectionInterface iid _ piid 
+  | piid == nullPtr  = return e_POINTER
+  | otherwise        = do
+     writeGUID piid (iidToGUID iid)
+     return s_OK
+
+foreign export stdcall dynamic
+    export_gi :: (ThisPtr -> Ptr GUID -> IO HRESULT) -> IO (Ptr ())
+
+getConnectionPointContainer :: IConnectionPointContainer ()
+                            -> ThisPtr
+                            -> Ptr (Ptr (IUnknown b))
+                            -> IO HRESULT
+getConnectionPointContainer ip _ pip = do
+   writeIUnknown True{-addRef-} pip ip
+   return s_OK
+
+foreign export stdcall dynamic
+    export_gcpc :: (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+
+advise :: IORef [(Word32,IUnknown ())]
+       -> IORef Word32
+       -> IID (IUnknown iid)
+       -> ThisPtr
+       -> PrimIP ()
+       -> Ptr Word32
+       -> IO HRESULT
+advise sinks cookie_ref iid this pUnkSink pdwCookie = do
+  ls      <- readIORef sinks
+  cookie  <- readIORef cookie_ref
+  ip      <- unmarshallIUnknown False pUnkSink
+  catch (do
+     ip2 <- ip # queryInterface iid
+     if nullPtr == pdwCookie then
+        return e_POINTER
+      else do
+        writeIORef cookie_ref (cookie+1)
+        writeIORef sinks ((cookie,castIface ip2):ls)
+        writeWord32 pdwCookie cookie
+        return s_OK
+   )(\ _ -> return cONNECT_E_CANNOTCONNECT)
+
+foreign export stdcall dynamic
+   export_adv :: (ThisPtr -> PrimIP () -> Ptr Word32 -> IO HRESULT) -> IO (Ptr ())
+
+unadvise :: IORef [(Word32,IUnknown ())]
+         -> ThisPtr
+         -> Word32
+         -> IO HRESULT
+unadvise sinks this dwCookie = do
+  ls     <- readIORef sinks
+  case break ((==dwCookie).fst) ls of
+    (ls,[])    -> return cONNECT_E_NOCONNECTION
+    (ls, _:rs) -> do
+	 -- just drop the interface pointer and let
+	 -- the GC release it.
+       writeIORef sinks (ls++rs)
+       return s_OK
+
+foreign export stdcall dynamic
+    export_unadv :: (ThisPtr -> Word32 -> IO HRESULT) -> IO (Ptr ())
+
+enumConnections :: IORef [(Word32,IUnknown ())]
+                -> ThisPtr
+	        -> Ptr (Ptr (IUnknown a))
+                -> IO HRESULT
+enumConnections sinks this ppCP
+  | ppCP == nullPtr  = return e_POINTER
+  | otherwise        = do
+    ls   <- readIORef sinks
+    vtbl <- mkEnumInterface (map snd ls) (fromIntegral sizeofPtr) (writeIUnknown True)
+    ip   <- createComInstance "" () (return ())
+	                      [mkIface iidIEnumConnections vtbl]
+			      iidIEnumConnections
+    writeIUnknown True ppCP ip
+    return s_OK
+
+foreign export stdcall dynamic
+    export_enumCP :: (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+\end{code}
+
+\begin{code}
+enumConnectionPoints :: [IConnectionPoint ()]
+                     -> ThisPtr
+                     -> Ptr (Ptr (IUnknown b))
+                     -> IO HRESULT
+enumConnectionPoints ls this ppEnum 
+  | ppEnum == nullPtr  = return e_POINTER
+  | otherwise	       = do
+     vtbl <- mkEnumInterface ls (fromIntegral sizeofPtr) (writeIUnknown True)
+     ip   <- createComInstance "" () (return ())
+	                           [mkIface iidIEnumConnectionPoints vtbl]
+				   iidIEnumConnectionPoints
+     writeIUnknown True ppEnum ip
+     return s_OK
+
+foreign export stdcall dynamic
+    export_eCP :: (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+
+findConnectionPoint :: [(IID (IUnknown ()), IConnectionPoint ())]
+		    -> ThisPtr
+		    -> Ptr GUID
+		    -> Ptr (Ptr (IUnknown ()))
+		    -> IO HRESULT
+findConnectionPoint ls this riid ppCP 
+  | ppCP == nullPtr  = return e_POINTER
+  | otherwise        = do
+     guid <- unmarshallGUID False riid
+     let iid = guidToIID guid
+     case (lookup iid ls) of
+       Nothing -> do
+          poke ppCP nullPtr
+          return cONNECT_E_NOCONNECTION
+       Just i  -> do
+          writeIUnknown True ppCP i
+	  return s_OK
+
+foreign export stdcall dynamic
+    export_fCP :: (ThisPtr -> Ptr GUID -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+
+\end{code}
+
+\begin{code}
+cONNECT_E_NOCONNECTION :: HRESULT
+cONNECT_E_NOCONNECTION = 0x80040200
+
+cONNECT_E_ADVISELIMIT :: HRESULT
+cONNECT_E_ADVISELIMIT  = 0x80040201
+
+cONNECT_E_CANNOTCONNECT :: HRESULT
+cONNECT_E_CANNOTCONNECT = 0x80040202
+
+cONNECT_E_OVERRIDDEN :: HRESULT
+cONNECT_E_OVERRIDDEN = 0x80040203
+\end{code}
+ comlib/EnumInterface.lhs view
@@ -0,0 +1,149 @@+%
+% (c) 1999, sof
+%
+
+Generic implementation of Com-style enumeration
+interfaces - give it the list to enumerate & you're there!
+
+\begin{code}
+module EnumInterface 
+	( 
+	  mkEnumInterface  -- :: [a]
+			   -- -> Int
+			   -- -> (Ptr a -> a -> IO ())
+			   -- -> IO (ComVTable iid objState)
+	) where
+
+import Word
+import Int
+import ComServ
+import ComException
+import Com ( HRESULT, writeIUnknown, IUnknown )
+import HDirect
+import Foreign.Ptr
+import IOExts
+import Monad ( when )
+
+type ThisPtr = Ptr (IUnknown ())
+\end{code}
+
+The state kept by each IEnum* instance:
+
+\begin{code}
+data EnumState a
+ = EnumState 
+     { elt      :: IORef ([a], Int)
+     , origElts :: [a]
+     , writeElt :: (Ptr (Ptr a) -> a -> IO ())
+     , sizeof   :: Int
+     }
+\end{code}
+
+The constructor doesn't have to do much, initialise the state
+shared by the different methods and create a method table
+containing them:
+
+\begin{code}
+mkEnumInterface :: [a]
+	        -> Int
+		-> (Ptr (Ptr a) -> a -> IO ())
+		-> IO (ComVTable iid objState)
+mkEnumInterface ls sizeof write = do
+  ref <- newIORef (ls, length ls)
+  let st = EnumState ref ls write sizeof
+  m_enumNext  <- export_enumNext  (enumNext st)
+  m_enumSkip  <- export_enumSkip  (enumSkip st)
+  m_enumReset <- export_enumReset (enumReset st)
+  m_enumClone <- export_enumClone (enumClone st)
+  createComVTable [m_enumNext, m_enumSkip, m_enumReset, m_enumClone]
+\end{code}
+
+An IEnum* interface allows you to iterate over a sequence *once*,
+i.e., it doesn't wrap around (but you can rewind the enumeration
+back to the beginning with IEnum::Reset()):
+
+\begin{code}
+enumNext :: EnumState a
+	 -> ThisPtr
+	 -> Word32
+	 -> Ptr (Ptr a)
+	 -> Ptr Word32
+	 -> IO HRESULT
+enumNext st this c pFetched pcFetched 
+  | pcFetched == nullPtr && c /= 1 = return e_INVALIDARG
+  | pFetched == nullPtr 	   = return e_POINTER
+  | otherwise			   = do
+     let ref = elt st
+     (elts, eltsLeft) <- readIORef ref
+     let
+      c_int = fromIntegral c
+      (hr, elts_to_fetch)
+       | c_int > eltsLeft  = (s_FALSE, eltsLeft)
+       | otherwise         = (s_OK,    c_int)
+       
+      elts_left = eltsLeft - elts_to_fetch
+
+     elts' <- fillIn pFetched elts_to_fetch  elts
+     when (pcFetched /= nullPtr)
+          (writeWord32 pcFetched (fromIntegral elts_to_fetch))
+     writeIORef ref (elts', elts_left)
+     return hr
+ where
+   wr_marshall = writeElt st
+
+   fillIn ptr 0 ls     = return ls
+   fillIn ptr n (x:xs) = do
+       wr_marshall ptr x
+       let ptr' = ptr `plusPtr` (fromIntegral (sizeof st))
+       fillIn ptr' (n-1) xs
+
+foreign export stdcall dynamic
+   export_enumNext :: (ThisPtr -> Word32 -> Ptr a -> Ptr Word32 -> IO HRESULT) -> IO (Ptr ())
+
+enumSkip :: EnumState a
+	 -> ThisPtr
+	 -> Word32
+	 -> IO HRESULT
+enumSkip st this c
+  | c == 0     = return e_INVALIDARG
+  | otherwise  = do
+     (elts, eltsLeft) <- readIORef (elt st)
+     let
+      c_int = fromIntegral c
+      (hr, elts_to_fetch)
+       | c_int > eltsLeft = (s_FALSE, eltsLeft)
+       | otherwise        = (s_OK,    c_int)
+
+      elts_left = take elts_to_fetch elts
+      x         = eltsLeft - elts_to_fetch
+
+     writeIORef (elt st) (elts_left, x)
+     return hr
+
+foreign export stdcall dynamic
+   export_enumSkip :: (ThisPtr -> Word32 -> IO HRESULT) -> IO (Ptr ())
+
+enumReset :: EnumState a
+	  -> ThisPtr
+	  -> IO HRESULT
+enumReset st _ = do
+  let ls = origElts st
+  writeIORef (elt st) (ls, length ls)
+  return s_OK
+
+foreign export stdcall dynamic
+   export_enumReset :: (ThisPtr -> IO HRESULT) -> IO (Ptr ())
+
+enumClone :: EnumState a
+	  -> ThisPtr
+	  -> Ptr (Ptr (IUnknown b))
+	  -> IO HRESULT
+enumClone st this out = do
+   vtbl <- mkEnumInterface (origElts st) (sizeof st) (writeElt st)
+   ip   <- cloneIPointer_prim this vtbl
+   writeIUnknown False out ip
+   return s_OK
+
+foreign export stdcall dynamic
+   export_enumClone :: (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+\end{code}
+ comlib/ExeServer.lhs view
@@ -0,0 +1,92 @@+
+\begin{code}
+{-# OPTIONS -#include "comPrim.h" #-}
+module ExeServer 
+	(
+	  runExeServer       -- :: ComponentInfo -> IO ()
+	, registerExeServer  -- :: String -> ComponentInfo -> IO ()
+	) where
+
+import ClassFactory
+import ComDll
+import ComPrim
+import Com
+import HDirect
+import Int
+import Foreign.StablePtr
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Char ( toLower )
+
+\end{code}
+
+\begin{code}
+runExeServer :: ComponentInfo -> IO ()
+runExeServer c = do
+  newStablePtr c
+  ev <- mkEvent
+  let c'=c{componentFinalise=componentFinalise c >> signalEvent ev}
+  ip <- createClassFactory (newInstance c' "" (componentFinalise c'))
+  pip    <- marshallIUnknown ip
+  pclsid <- marshallCLSID (componentCLSID c)
+  dw    <- coRegisterClassObject (castForeignPtr pclsid) pip
+  			(fromIntegral (fromEnum CLSCTX_LOCAL_SERVER))
+  			(fromIntegral (fromEnum REGCLS_SINGLEUSE))
+  waitForEvent ev
+  coRevokeClassObject dw
+  return ()
+  
+registerExeServer :: String -> ComponentInfo -> IO ()
+registerExeServer arg ci
+  | null arg  = return ()
+  | otherwise = do
+   let
+    arg_low  = map toLower (tail arg)
+    is_unreg = arg_low == "unregserver"
+    is_reg   = arg_low == "regserver"
+
+   if not is_unreg && not is_reg then
+      return ()
+    else do
+      path <- getModuleFileName nullPtr
+      (registerComponent ci) ci path is_reg
+      (if is_reg then stdRegComponent else stdUnRegComponent) ci False path
+\end{code}
+
+\begin{code}
+data REGCLS 
+ = REGCLS_SINGLEUSE      --   = 0, 
+ | REGCLS_MULTIPLEUSE    --   = 1, 
+ | REGCLS_MULTI_SEPARATE --   = 2, 
+ | REGCLS_SUSPENDED      --   = 4, 
+ | REGCLS_SURROGATE      --   = 8, 
+
+instance Enum REGCLS where
+  fromEnum ctx =
+    case ctx of
+      REGCLS_SINGLEUSE      -> 0
+      REGCLS_MULTIPLEUSE    -> 1
+      REGCLS_MULTI_SEPARATE -> 2
+      REGCLS_SUSPENDED      -> 4
+      REGCLS_SURROGATE      -> 8
+ 
+  toEnum c =
+    case c of
+      0 -> REGCLS_SINGLEUSE
+      1 -> REGCLS_MULTIPLEUSE
+      2 -> REGCLS_MULTI_SEPARATE
+      4 -> REGCLS_SUSPENDED
+      8 -> REGCLS_SURROGATE
+ 
+
+foreign import ccall "mkEvent" mkEvent :: IO (Ptr ())
+
+foreign import ccall "signalEvent" signalEvent :: Ptr () -> IO ()
+
+foreign import ccall "waitForEvent" waitForEvent :: Ptr () -> IO ()
+
+foreign import stdcall "CoRevokeClassObject"
+	coRevokeClassObject :: Word32 -> IO HRESULT
+
+\end{code}
+
+ comlib/HDirect.lhs view
@@ -0,0 +1,1137 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+
+Stubs for marshalling and unmarshalling primitive
+types.
+
+\begin{code}
+{-# OPTIONS -#include "PointerSrc.h" #-}
+module HDirect 
+	(
+	  module HDirect
+
+	, Int8
+	, Int16
+	, Int32
+	, Int64
+
+	, Word8
+	, Word16
+	, Word32
+	, Word64
+
+	, Char
+	, Double
+	, Float
+	, Bool
+	
+	, Ptr
+
+	, StablePtr
+	, deRefStablePtr
+	, free
+	
+	) where
+
+import Char
+import Int  ( Int8, Int16, Int32, Int64 )
+import Word ( Word8, Word16, Word32, Word64 )
+--import Addr
+import Monad
+import Pointer
+import IOExts ( unsafePerformIO )
+
+
+import Foreign.StablePtr
+import Foreign.Storable
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Foreign.C.Types ( CChar )
+import Foreign.C.String
+import Foreign.Marshal.Alloc (mallocBytes, free)
+
+import Bits
+{- BEGIN_GHC_ONLY
+import GlaExts ( Int(..), Int# )
+#if __GLASGOW_HASKELL__ >= 505
+import GHC.Base ( getTag )
+#else
+import GlaExts ( dataToTag# )
+getTag :: a -> Int#
+getTag x = dataToTag# x
+{- WAS: x `seq` dataToTag# x
+        this won't work 
+	  (seq's type is a->b->b, where b isn't 'open',
+           but has to be of kind *)
+-}
+#endif
+   END_GHC_ONLY -}
+
+infixl 5 .+.
+
+{- BEGIN_GHC_ONLY
+#if __GLASGOW_HASKELL__ >= 601
+foreignPtrToPtr = unsafeForeignPtrToPtr
+#endif
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+-- Versionitis. If your version of Hugs is troubled by this one, simply comment it out.
+foreignPtrToPtr = unsafeForeignPtrToPtr
+{- END_NOT_FOR_GHC -}
+\end{code}
+
+At the moment the IDL compiler will emit calls to types with identity marshallers
+(i.e., by-value marshallers for primitive, FFI-recognised types), so we need
+to provide stubs for these here.
+
+
+Int* marshalling functions:
+
+\begin{code}
+marshallInt :: Int -> IO Int
+marshallInt x = return x
+
+unmarshallInt :: Int -> IO Int
+unmarshallInt x = return x
+
+writeInt :: Ptr Int -> Int -> IO ()
+writeInt ptr v = poke ptr v
+
+readInt :: Ptr Int -> IO Int
+readInt ptr = peek ptr
+
+--ToDo: generate host-specific versions of 
+sizeofInt :: Word32
+sizeofInt = fromIntegral (sizeOf (0 :: Int))
+
+--Int8
+marshallInt8 :: Int8 -> IO Int8
+marshallInt8 v = return v
+
+unmarshallInt8 :: Int8 -> IO Int8
+unmarshallInt8 v = return v
+
+writeInt8 :: Ptr Int8 -> Int8 -> IO ()
+writeInt8 ptr v = poke ptr v
+
+readInt8 :: Ptr Int8 -> IO Int8
+readInt8 ptr = peek ptr
+
+sizeofInt8 :: Word32
+sizeofInt8 = fromIntegral (sizeOf (1 :: Int8))
+
+--Int16
+marshallInt16 :: Int16 -> IO Int16
+marshallInt16 x = return x
+unmarshallInt16 :: Int16 -> IO Int16
+unmarshallInt16 x = return x
+
+writeInt16 :: Ptr Int16 -> Int16 -> IO ()
+writeInt16 ptr v = poke ptr v
+
+readInt16 :: Ptr Int16 -> IO Int16
+readInt16 ptr = peek ptr
+
+sizeofInt16 :: Word32
+sizeofInt16 = fromIntegral (sizeOf (0 :: Int16))
+
+-- Int32
+marshallInt32 :: Int32 -> IO Int32
+marshallInt32 x = return x
+
+unmarshallInt32 :: Int32 -> IO Int32
+unmarshallInt32 x = return x
+
+writeInt32 :: Ptr Int32 -> Int32 -> IO ()
+writeInt32 ptr v = poke ptr v
+
+readInt32 :: Ptr Int32 -> IO Int32
+readInt32 ptr = peek ptr
+
+sizeofInt32 :: Word32
+sizeofInt32 = fromIntegral (sizeOf (0::Int32))
+
+marshallInt64 :: Int64 -> IO Int64
+marshallInt64 x = return x
+
+unmarshallInt64 :: Int64 -> IO Int64
+unmarshallInt64 x = return x
+
+writeInt64 :: Ptr Int64 -> Int64 -> IO ()
+readInt64 :: Ptr Int64 -> IO Int64
+writeInt64 ptr v = poke ptr v
+readInt64 ptr = peek ptr
+{-
+{- BEGIN_NOT_FOR_GHC -}
+writeInt64 ptr v = writeI64 ptr (fromIntegral lo) (fromIntegral hi)
+ where
+   (hi,lo) = (fromIntegral v) `divMod` (toInteger (maxBound :: Int) + 1)
+readInt64 ptr = do
+  px <- readI64 ptr
+  lo <- peekElemOff px 0
+  hi <- peekElemOff px 1
+  free ptr
+  return (fromIntegral ((toInteger lo) + (toInteger hi) * (toInteger (maxBound :: Int) + 1)))
+{- END_NOT_FOR_GHC -}
+-}
+
+sizeofInt64 :: Word32
+sizeofInt64 = fromIntegral (sizeOf (0 :: Int64))
+
+type Hyper   = Int64
+marshallHyper :: Hyper -> IO Int64
+unmarshallHyper :: Int64 -> IO Hyper
+writeHyper :: Ptr Hyper -> Hyper -> IO ()
+readHyper :: Ptr Hyper -> IO Hyper
+sizeofHyper :: Word32
+
+marshallHyper   = marshallInt64
+unmarshallHyper = unmarshallInt64
+writeHyper      = writeInt64
+readHyper       = readInt64
+sizeofHyper     = fromIntegral (sizeOf (0 :: Int64))
+
+writeInteger :: Ptr Integer -> Integer -> IO ()
+writeInteger ptr x = writeInt64 (castPtr ptr) (fromIntegral x)
+
+readInteger :: Ptr Integer -> IO Integer
+readInteger ptr = do
+  x <- readInt64 (castPtr ptr)
+  return (fromIntegral x)
+
+marshallInteger :: Integer -> IO (Int32, Int32)
+marshallInteger i =  return (fromInteger lo, fromInteger hi)
+ where
+   (hi,lo) = i `divMod` (toInteger (maxBound :: Int) + 1)
+
+unmarshallInteger :: (Int32,Int32) -> IO Integer
+unmarshallInteger (hi,lo) =  return ((toInteger lo) + (toInteger hi) * (toInteger (maxBound :: Int) + 1))
+
+marshallUInteger :: Integer -> IO (Int32, Int32)
+marshallUInteger = marshallInteger
+
+unmarshallUInteger :: (Int32,Int32) -> IO Integer
+unmarshallUInteger = unmarshallInteger
+
+readUInteger :: Ptr Integer -> IO Integer
+readUInteger = readInteger
+
+writeUInteger :: Ptr Integer -> Integer -> IO ()
+writeUInteger = writeInteger
+
+\end{code}
+
+Characters and bytes:
+
+NOTE: we assume that Char is CChar (==an 8-bit byte.)
+
+\begin{code}
+marshallChar :: Char -> IO Char
+marshallChar x = return x
+
+unmarshallChar :: Char -> IO Char
+unmarshallChar x = return x
+
+writeChar :: Ptr Char -> Char -> IO ()
+writeChar ptr v = poke ((castPtr ptr) :: Ptr CChar) (castCharToCChar v)
+
+readChar :: Ptr Char -> IO Char
+readChar ptr = peek ((castPtr ptr) :: Ptr CChar) >>= return.castCCharToChar
+
+sizeofChar :: Word32
+sizeofChar     = fromIntegral (sizeOf (undefined :: CChar))
+
+-- wide chars.
+type Wchar_t = Word16
+
+marshallWchar_t :: Wchar_t -> IO Wchar_t
+marshallWchar_t   = marshallWord16
+unmarshallWchar_t :: Wchar_t -> IO Wchar_t
+unmarshallWchar_t = unmarshallWord16
+writeWchar_t :: Ptr Wchar_t -> Wchar_t -> IO ()
+writeWchar_t      = writeWord16
+readWchar_t :: Ptr Wchar_t -> IO Wchar_t
+readWchar_t       = readWord16
+sizeofWchar_t :: Word32
+sizeofWchar_t     = fromIntegral (sizeOf (0::Word16))
+
+
+type Octet   = Byte
+type Byte    = Word8
+
+marshallByte :: Byte -> IO Byte
+marshallByte   = marshallWord8
+unmarshallByte :: Byte -> IO Byte
+unmarshallByte = unmarshallWord8
+writeByte :: Ptr Byte -> Byte -> IO ()
+writeByte      = writeWord8
+readByte :: Ptr Byte -> IO Byte
+readByte       = readWord8
+sizeofByte :: Word32
+sizeofByte     = fromIntegral (sizeOf (0::Word8))
+\end{code}
+
+Words:
+
+\begin{code}
+-- Word8:
+marshallWord8 :: Word8 -> IO Word8
+marshallWord8 x = return x
+
+unmarshallWord8 :: Word8 -> IO Word8
+unmarshallWord8 x = return x
+
+writeWord8 :: Ptr Word8 -> Word8 -> IO ()
+writeWord8 ptr v = poke ptr v
+
+readWord8 :: Ptr Word8 -> IO Word8
+readWord8 ptr = peek ptr
+
+sizeofWord8 :: Word32
+sizeofWord8 = fromIntegral (sizeOf (undefined :: Word8))
+
+-- Word16:
+marshallWord16 :: Word16 -> IO Word16
+marshallWord16 x = return x
+
+unmarshallWord16 :: Word16 -> IO Word16
+unmarshallWord16 x = return x
+
+writeWord16 :: Ptr Word16 -> Word16 -> IO ()
+writeWord16 ptr v = poke ptr v
+
+readWord16 :: Ptr Word16 -> IO Word16
+readWord16 ptr = peek ptr
+
+sizeofWord16 :: Word32
+sizeofWord16 = fromIntegral (sizeOf (undefined :: Word16))
+
+-- Word32:
+marshallWord32 :: Word32 -> IO Word32
+marshallWord32 x = return x
+
+unmarshallWord32 :: Word32 -> IO Word32
+unmarshallWord32 x = return x
+
+writeWord32 :: Ptr Word32 -> Word32 -> IO ()
+writeWord32 ptr v = poke ptr v
+
+readWord32 :: Ptr Word32 -> IO Word32
+readWord32 ptr = peek ptr
+
+sizeofWord32 :: Word32
+sizeofWord32 = fromIntegral (sizeOf (undefined :: Word32))
+
+marshallWord64 :: Word64 -> IO Word64
+marshallWord64 x = return x
+
+unmarshallWord64 :: Word64 -> IO Word64
+unmarshallWord64 x = return x
+
+writeWord64 :: Ptr Word64 -> Word64 -> IO ()
+readWord64 :: Ptr Word64 -> IO Word64
+{- BEGIN_NOT_FOR_GHC -}
+writeWord64 _ _ = undefined
+readWord64 _ = undefined
+{- END_NOT_FOR_GHC -}
+{- BEGIN_GHC_ONLY
+writeWord64 p v = poke p v
+readWord64 p = peek p
+   END_GHC_ONLY -}
+
+sizeofWord64 :: Word32
+sizeofWord64 = fromIntegral (sizeOf (undefined :: Word64))
+
+\end{code}
+
+Addr marshallers:
+
+begin{code}
+marshallAddr :: Ptr Addr -> IO Addr
+marshallAddr p = return p
+
+unmarshallAddr :: Ptr Addr -> IO Addr
+unmarshallAddr p = return p
+
+writeAddr :: Ptr Addr -> Addr -> IO ()
+{- BEGIN_DEBUG
+writeAddr ptr a | ptr == nullAddr = ioError (userError "writeAddr: NULL pointer")
+   END_DEBUG -}
+writeAddr ptr a = writeAddrOffAddr ptr 0 a
+
+readAddr :: Ptr Addr -> IO Addr
+readAddr a = readAddrOffAddr a 0
+
+sizeofAddr :: Word32
+sizeofAddr     = fromIntegral (sizeOf (undefined :: Foreign.Ptr.Ptr ()))
+
+freeAddr :: Addr -> IO ()
+freeAddr = free
+end{code}
+
+Double marshallers:
+
+\begin{code}
+marshallDouble :: Double -> IO Double
+marshallDouble x = return x
+
+unmarshallDouble :: Double -> IO Double
+unmarshallDouble x = return x
+
+writeDouble :: Ptr Double -> Double -> IO ()
+writeDouble ptr x = poke ptr x
+
+readDouble :: Ptr Double -> IO Double
+readDouble ptr = peek ptr
+
+sizeofDouble :: Word32
+sizeofDouble   = fromIntegral (sizeOf (undefined :: Double))
+
+writeFloat :: Ptr Float -> Float -> IO ()
+writeFloat ptr x = poke ptr x
+
+readFloat :: Ptr Float -> IO Float
+readFloat ptr = peek ptr
+
+sizeofFloat :: Word32
+sizeofFloat   = fromIntegral (sizeOf (undefined :: Float))
+
+\end{code}
+
+Booleans - represented externally by a long (Int32):
+
+\begin{code}
+marshallBool :: Bool -> IO Int32
+marshallBool v = marshallInt32 (if v then (-1) else 0)
+
+unmarshallBool :: Int32 -> IO Bool
+unmarshallBool v = return (v /= 0)
+
+writeBool :: Ptr Bool -> Bool -> IO ()
+writeBool ptr v = writeInt32 (castPtr ptr) (if v then (-1) else 0)
+
+readBool :: Ptr Bool -> IO Bool
+readBool ptr = do
+  v <- readInt32 (castPtr ptr)
+  return ( v /= 0 )
+
+sizeofBool :: Word32
+sizeofBool = fromIntegral (sizeOf (0 :: Int32))
+\end{code}
+
+\begin{code}
+addNCastPtr :: Ptr a -> Word32 -> Ptr b
+addNCastPtr v off = v `plusPtr` (fromIntegral off)
+
+derefPtr :: Ptr (Ptr a) -> IO (Ptr a)
+derefPtr p = peek p
+
+indexPtr :: Ptr (Ptr a) -> Int -> IO (Ptr a)
+indexPtr p off = peekElemOff p off
+\end{code}
+
+The unit of allocation is an 8-bit byte.
+
+\begin{code}
+allocOutPtr :: IO (Ptr a)
+allocOutPtr = alloc 4 -- 4 bytes in a pointer. ToDo: 64-bit platform'ify.
+
+allocBytes :: Int -> IO (Ptr a)
+allocBytes len = alloc (fromIntegral len)
+
+allocWords :: Int -> IO (Ptr a)
+allocWords len = alloc (4 * fromIntegral len)
+
+
+alloc :: Word32 -> IO (Ptr a)
+alloc s = mallocBytes (fromIntegral s)
+
+doThenFree ::(Ptr a -> IO ()) -> (Ptr b -> IO c) -> Ptr d -> IO c
+doThenFree f act ptr = do
+   v <- act (castPtr ptr)
+   f (castPtr ptr)
+   return v
+
+trivialFree :: a -> IO ()
+trivialFree _ = return ()
+
+fillIn :: Int -> (Ptr a -> IO ()) -> IO (Ptr a)
+fillIn sz refreemarshall = do
+  ptr <- allocBytes sz
+  refreemarshall ptr
+  return ptr
+
+\end{code}
+
+[ptr]Ptr marshalling
+
+\begin{code}
+marshallPtr :: Ptr a -> IO (Ptr a)
+marshallPtr v = return v
+
+unmarshallPtr :: Ptr a -> IO (Ptr a)
+unmarshallPtr v = return v
+
+writePtr :: Ptr (Ptr a) -> Ptr a -> IO ()
+writePtr a v = poke a v
+
+readPtr :: Ptr a -> IO (Ptr b)
+readPtr a = peek (castPtr a)
+
+writefptr :: Ptr b -> ForeignPtr a -> IO ()
+writefptr p v = poke (castPtr p) (foreignPtrToPtr v)
+\end{code}
+
+[unique]Ptr marshalling
+
+\begin{code}
+marshallunique :: (IO (Ptr a))
+               -> (Ptr a -> a -> IO ())
+	       -> Maybe a
+	       -> IO (Ptr a)
+marshallunique allocRef marshallInto mb = 
+  case mb of
+    Nothing -> return nullPtr
+    Just x  -> marshallref allocRef marshallInto x
+
+marshallMaybe :: (a -> IO b) -> b -> Maybe a -> IO b
+marshallMaybe _mshall def  Nothing  = return def
+marshallMaybe mshall  _def (Just x) = mshall x
+
+writeMaybe :: (Ptr a -> a -> IO ())
+           -> Ptr (Maybe a)
+	   -> Maybe a
+	   -> IO ()
+writeMaybe _  ptr Nothing  = writePtr (castPtr ptr) nullPtr
+writeMaybe wr ptr (Just x) = wr (castPtr ptr) x
+
+readMaybe :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
+readMaybe rd ptr
+ | ptr == nullPtr = return Nothing
+ | otherwise      = rd ptr >>= return . Just
+
+writeunique :: IO (Ptr a)
+	    -> (Ptr a -> a -> IO ())
+	    -> Ptr (Maybe a)
+	    -> Maybe a
+	    -> IO ()
+writeunique allocRef marshallInto p mb =
+  case mb of
+    Nothing  -> writePtr (castPtr p) nullPtr
+    Just x   -> writeref allocRef marshallInto (castPtr p) x
+
+unmarshallunique :: (Ptr a -> IO a) -> Ptr a -> IO (Maybe a)
+unmarshallunique refUnmarshall ptr
+ | ptr == nullPtr = return Nothing
+ | otherwise      = do
+    x <- unmarshallref refUnmarshall ptr
+    return (Just x)
+
+
+readunique :: (Ptr a -> IO a) -> Ptr b -> IO (Maybe a)
+readunique refUnmarshall ptr
+ | ptr == nullPtr = return Nothing
+ | otherwise      = do
+   v <- readPtr (castPtr ptr)
+   if nullPtr == v then
+      return Nothing
+    else do
+      x <- refUnmarshall (castPtr v)
+      return (Just x)
+
+freeunique :: (Ptr a -> IO ()) -> Ptr (Ptr a) -> IO ()
+freeunique freeptee ptr
+ | ptr == nullPtr = return ()
+ | otherwise      = do
+    ptr' <- derefPtr ptr
+    freeptee ptr'
+    free ptr
+
+\end{code}
+
+Marshalling [unique]void* pointers
+
+\begin{code}
+marshallunique_ptr :: Maybe (Ptr a) -> IO (Ptr a)
+marshallunique_ptr mb = 
+  case mb of
+    Nothing -> marshallPtr nullPtr
+    Just x  -> marshallPtr x
+\end{code}
+
+
+[ref]Ptr marshalling
+
+\begin{code}
+marshallref :: (IO (Ptr a)) -> (Ptr a -> a -> IO ()) -> a -> IO (Ptr a)
+marshallref allocRef marshallInto v = do
+   px <- allocRef
+   marshallInto px v
+   return px
+
+writeref :: (IO (Ptr a)) -> (Ptr a -> a -> IO ()) -> Ptr (Ptr a) -> a -> IO ()
+writeref allocRef marshallInto ptr v = do
+  px <- marshallref allocRef marshallInto v
+  writePtr ptr px
+
+unmarshallref :: (Ptr a -> IO b) -> Ptr a -> IO b
+unmarshallref refUnmarshall ptr = refUnmarshall ptr
+
+readref :: (Ptr a -> IO a) -> Ptr (Ptr a) -> IO a
+readref refUnmarshall ptr = do
+  px <- readPtr ptr
+  unmarshallref refUnmarshall (castPtr px)
+
+freeref :: (Ptr b -> IO ()) -> Ptr a -> IO ()
+freeref free_inner pptr = do
+   ptr <- readPtr (castPtr pptr)
+   free_inner ptr
+   free pptr
+\end{code}
+
+
+All by-reference marshalling and unmarshalling functions
+of enums can be expressed using these two stubs:
+
+\begin{code}
+writeenum16 :: (b -> IO Int16) -> Ptr Int16 -> b -> IO ()
+writeenum16 marshall pv v =
+  marshall v >>= \ x ->
+  writeInt16 pv x
+
+readenum16 :: (Int16 -> IO a) -> Ptr (Int16) -> IO a
+readenum16 unmarshall pv = do
+  v <- readInt16 pv
+  unmarshall v
+
+marshallEnum16 :: Enum a => a -> IO Int16
+marshallEnum16 v = return (fromIntegral (fromEnum v))
+
+unmarshallEnum16 :: Enum a => Int16 -> IO a
+unmarshallEnum16 x = return (toEnum (fromIntegral x))
+
+marshallEnum32 :: Enum a => a -> IO Int32
+marshallEnum32 v = return (fromIntegral (fromEnum v))
+
+unmarshallEnum32 :: Enum a => Int32 -> IO a
+unmarshallEnum32 x = return (toEnum (fromIntegral x))
+
+writeEnum32 :: Enum a => Ptr b -> a -> IO ()
+writeEnum32 p v = writeInt32 (castPtr p) (fromIntegral (fromEnum v))
+
+readEnum32 :: Enum a => Ptr b -> IO a
+readEnum32 p = do
+  x <- readInt32 (castPtr p)
+  return (toEnum (fromIntegral x))
+
+writeEnum16 :: Enum a => Ptr b -> a -> IO ()
+writeEnum16 p v = writeInt16 (castPtr p) (fromIntegral (fromEnum v))
+
+readEnum16 :: Enum a => Ptr b -> IO a
+readEnum16 p = do
+  x <- readInt16 (castPtr p)
+  return (toEnum (fromIntegral x))
+
+\end{code}
+
+\begin{code}
+marshalllist :: Word32
+	     -> (Ptr a -> a -> IO ())
+	     -> [a]
+	     -> IO (Ptr b)
+marshalllist szof writeelt ls = do
+ arr <- alloc (len*szof)
+ foldM writeElt (castPtr arr) ls
+ return (castPtr arr)
+  where
+   len = fromIntegral (length ls)
+
+   writeElt addr v = do
+     writeelt addr v
+     return (addNCastPtr addr szof)
+
+unmarshalllist :: Word32 -> Word32 -> Word32 -> (Ptr any -> IO a) -> Ptr b -> IO [a]
+unmarshalllist szof offset len unpack ptr = do
+ let ptr0 = addNCastPtr ptr (offset*szof)
+ loop ptr0 len
+  where
+   loop _ 0 = return []
+   loop p n = do
+    v  <- unpack p
+    let p' = addNCastPtr p szof
+    vs <- loop p' (n-1)
+    return (v:vs)
+
+unmarshallSingle :: (Ptr a -> IO a) -> Ptr a -> IO [a]
+unmarshallSingle ref ptr 
+ | ptr == nullPtr = return []
+ | otherwise      = do
+      x <- ref ptr
+      return [x]
+
+writelist :: Bool -> Word32 -> (Ptr a -> a -> IO ()) -> Ptr [a] -> [a] -> IO ()
+writelist do_alloc szof writeelt pptr ls = do
+ the_ptr <- 
+    (if do_alloc then do
+        ptr <- alloc (szof * fromIntegral len)
+	writePtr (castPtr pptr) ptr
+	return (castPtr ptr)
+      else
+        return (castPtr pptr))
+ foldM writeElt the_ptr ls
+ return ()
+  where
+   len = length ls
+
+   writeElt addr v = do
+    writeelt addr v
+    return (addNCastPtr addr szof)
+
+readlist :: Word32 -> Word32 -> (Ptr a -> IO a) -> Ptr [a] -> IO [a]
+readlist szof len unpack ptr = do
+ let ptr0 = castPtr ptr
+ loop ptr0 len
+  where
+   loop _ 0 = return []
+   loop p n = do
+    v  <- unpack p
+    let p' = addNCastPtr p szof
+    vs <- loop p' (n-1)
+    return (v:vs)
+
+freelist :: Word32 -> Word32 -> (Ptr a -> IO ()) -> Ptr [a] -> IO ()
+freelist szof len free_elt ptr = do
+	go (castPtr ptr) len
+	free ptr
+  where
+    go _pptr 0 = return ()
+    go pptr  x = do
+       p <- readPtr pptr
+       free_elt p
+       let pptr' = addNCastPtr pptr szof
+       go pptr' (x-1)
+
+\end{code}
+
+Unpacking null terminated character strings:
+
+\begin{code}
+marshallString :: String -> IO (Ptr String)
+marshallString str = do
+ pstr  <- alloc (len*sizeofChar)
+ pstr' <- foldM writeElt (castPtr pstr) str
+ writeChar (castPtr pstr') '\0'
+ return pstr
+  where
+   len = fromIntegral (length str + 1)
+
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+marshallBString :: Int -> String -> IO (Ptr String)
+marshallBString len str = do
+ pstr  <- alloc (len'*sizeofChar)
+ pstr' <- foldM writeElt (castPtr pstr) (take len str)
+ writeChar (castPtr pstr') '\0'
+ return pstr
+  where
+   len' = fromIntegral (len + 1)
+
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+unmarshallString :: Ptr String -> IO String
+unmarshallString ptr
+ | ptr == nullPtr  = return ""
+ | otherwise	   = do
+   let ptr0 = addNCastPtr ptr 0
+   loop ptr0
+  where
+   loop p = do
+    v  <- readChar p
+    if v == '\0'
+     then return []
+     else do
+       let p' = addNCastPtr p sizeofChar
+       vs <- loop p'
+       return (v:vs)
+
+-- at most len chars. or zero terminated.
+unmarshallBString :: Int -> Ptr String -> IO String
+unmarshallBString len ptr
+ | ptr == nullPtr  = return ""
+ | otherwise	   = do
+   let ptr0 = addNCastPtr ptr 0
+   loop ptr0 0
+  where
+   loop _ n | n > len = return ""
+   loop p n = do
+    v  <- readChar p
+    if v == '\0'
+     then return []
+     else do
+       let p' = addNCastPtr p sizeofChar
+       vs <- loop p' (n+1)
+       return (v:vs)
+
+readString :: Ptr (Ptr String) -> IO String
+readString pstr = do
+  ptr <- readPtr pstr
+  unmarshallString ptr
+
+readBString :: Int -> Ptr (Ptr String) -> IO String
+readBString len pstr = do
+  ptr <- readPtr pstr
+  unmarshallBString len ptr
+
+writeString :: Bool -> Ptr String -> String -> IO ()
+writeString do_alloc ppstr str = do
+  pstr <-
+    if not do_alloc then
+       return (castPtr ppstr)
+     else do
+       arr <- alloc (fromIntegral string_len)
+       writePtr (castPtr ppstr) arr
+       return arr
+  pstr' <- foldM writeElt (castPtr pstr) str
+  writeChar (castPtr pstr') '\0'
+ where
+   string_len = length str + 1 {- terminator -}
+
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+writeBString :: Bool -> Int -> Ptr a -> String -> IO ()
+writeBString do_alloc len ptr str = do
+  pstr  <-
+    if do_alloc then
+        alloc (fromIntegral len * sizeofChar)
+    else
+        return (castPtr ptr)
+  pstr' <- foldM writeElt pstr (take len str)
+  writeChar pstr' '\0'
+ where
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+freeString :: Ptr String -> IO ()
+freeString = free
+\end{code}
+
+Sequence marshallers - i.e., R/W a sequence of
+values to/from a list.
+
+\begin{code}
+marshallSequence :: (Ptr a -> a -> IO ())
+		 -> (Ptr a -> IO ())
+		 -> Word32
+		 -> Maybe Word32
+		 -> [a]
+		 -> IO (Ptr a)
+marshallSequence wElt wTermin szElt mbLen ls = do
+   pseq  <- alloc (len*szElt) -- assume that the sequence is packed without gaps.
+   pseq' <- foldM writeElt pseq the_ls
+   wTermin pseq'
+   return pseq'
+  where
+    (len, the_ls) = 
+      case mbLen of
+        Nothing -> (fromIntegral (length ls + 1), ls)
+	Just x  -> (x + 1, take (fromIntegral x) ls)
+
+    writeElt addr v = do
+      wElt addr v
+      return (addNCastPtr addr szElt)
+
+unmarshallSequence :: ( Eq a )
+		   => (Ptr (Ptr a) -> IO a)
+		   -> (Ptr (Ptr a) -> IO Bool)
+		   -> Word32
+		   -> Maybe Word32
+		   -> Ptr (Ptr a)
+		   -> IO [a]
+unmarshallSequence rElt termPred szElt mbLen ptr
+ | ptr == nullPtr  = return []
+ | otherwise	   = do
+   let ptr0 = addNCastPtr ptr 0
+   loop 0 ptr0
+  where
+   lenPred = 
+     case mbLen of
+       Nothing -> const False
+       Just x  -> \ y -> y >= x
+
+   loop len p = do
+    flg <- termPred p
+    if flg || (lenPred len)
+     then return []
+     else do
+       v  <- rElt p
+       let p' = addNCastPtr p szElt
+       vs <- loop (len+1) p'
+       return (v:vs)
+
+readSequence :: ( Eq a )
+	     => (Ptr (Ptr a) -> IO a)
+	     -> (Ptr (Ptr a) -> IO Bool)
+	     -> Word32
+	     -> Maybe Word32
+	     -> Ptr (Ptr a)
+	     -> IO [a]
+readSequence rElt termPred szElt mbLen ptr = do
+  ptr' <- readPtr ptr
+  unmarshallSequence rElt termPred szElt mbLen (castPtr ptr')
+
+writeSequence :: ( Eq a )
+	      => Bool
+	      -> (Ptr a -> a -> IO ())
+	      -> (Ptr a -> IO ())
+	      -> Word32
+	      -> Maybe Word32
+	      -> Ptr a 
+	      -> [a] 
+	      -> IO ()
+writeSequence do_alloc wElt wTermin szElt mbLen ppseq ls = do
+  pseq <-
+    if not do_alloc then
+       return (castPtr ppseq)
+     else do
+       arr <- alloc (szElt * seq_len)
+       writePtr (castPtr ppseq) arr
+       return arr
+  pseq' <- foldM writeElt pseq the_ls
+  wTermin pseq'
+ where
+   (seq_len, the_ls) = 
+      case mbLen of
+        Nothing -> (fromIntegral (length ls + 1), ls)
+	Just x  -> (x + 1, take (fromIntegral x) ls)
+
+   writeElt addr v = do
+     wElt addr v
+     return (addNCastPtr addr szElt)
+
+freeSequence :: Ptr a -> IO ()
+freeSequence = free
+\end{code}
+
+\begin{code}
+-- at most len elements
+marshallblist :: Word32 -> Word32 -> (Ptr a -> a -> IO ()) -> [a] -> IO (Ptr [a])
+marshallblist szof l writeelt ls = do
+ arr <- alloc (l'*szof)
+ foldM writeElt (castPtr arr) ls
+ return arr
+  where
+   l' = atLeast l (fromIntegral (0::Int)) ls
+
+   atLeast len  n _ | len == n = len
+   atLeast _len n [] = n
+   atLeast len  n (_:xs) = atLeast len (n+1) xs
+
+   writeElt addr v = do
+    writeelt addr v
+    return (addNCastPtr addr szof)
+
+writeblist :: Word32 -> Word32 -> (Ptr a -> a -> IO ()) -> Ptr [a] -> [a] -> IO ()
+writeblist szof len writeelt ptr ls = do
+ foldM writeElt (castPtr ptr) (take (fromIntegral len) ls)
+ return ()
+  where
+
+   writeElt addr v = do
+    writeelt addr v
+    return (addNCastPtr addr szof)
+
+readblist :: Word32 -> Word32 -> (Ptr a -> IO a) -> Ptr a -> IO [a]
+readblist szof len unpack ptr = do
+ let ptr0 = castPtr ptr
+ loop ptr0 len
+  where
+   loop _p 0 = return []
+   loop p n  = do
+    v  <- unpack p
+    let p' = addNCastPtr p szof
+    vs <- loop p' (n-1)
+    return (v:vs)
+
+\end{code}
+
+Misc coercion functions/shortcuts:
+(ToDo: try to avoid generating them in the first place!)
+
+\begin{code}
+word16ToInt32 :: Word16 -> Int32
+word16ToInt32 w = fromIntegral w -- intToInt32 (word16ToInt w)
+
+-- This coercion is relying on no exceptions being thrown if
+-- the Word32 > (maxBound::Int32).
+word32ToInt32 :: Word32 -> Int32
+word32ToInt32 w = fromIntegral w
+
+-- This coercion is reling on no exceptions being thrown if w < 0.
+int32ToWord32 :: Int32 -> Word32
+int32ToWord32 w = fromIntegral w
+
+int16ToWord32 :: Int16 -> Word32
+int16ToWord32 w = fromIntegral w -- intToWord32 (int16ToInt w)
+
+intToChar :: Int -> Char
+intToChar = chr
+
+charToInt32 :: Char -> Int32
+charToInt32 c = fromIntegral (ord c)
+
+word32ToChar :: Word32 -> Char
+word32ToChar w = chr (fromIntegral w)
+
+charToWord32 :: Char -> Word32
+charToWord32 c = fromIntegral (ord c)
+
+\end{code}
+
+\begin{code}
+toInt32 :: Integral a => a -> Int32
+toInt32 i = fromIntegral i -- intToInt32 (toInt i)
+
+toInt16 :: Integral a => a -> Int16
+toInt16 i = fromIntegral i -- intToInt16 (toInt i)
+\end{code}
+
+ForeignPtr marshallers:
+
+\begin{code}
+marshallFO :: ForeignPtr a -> IO (ForeignPtr a)
+marshallFO x = return x
+
+unmarshallFO :: ForeignPtr a -> IO (ForeignPtr a)
+unmarshallFO x = return x
+
+writeFO :: Ptr (ForeignPtr a) -> ForeignPtr a -> IO ()
+writeFO ptr fo = poke (castPtr ptr) (foreignPtrToPtr fo)
+
+-- a C pointer, really.
+sizeofForeignPtr :: Word32
+sizeofForeignPtr = sizeofPtr
+
+nullFinaliser :: FunPtr (Ptr a -> IO ())
+nullFinaliser = castFunPtr (castPtrToFunPtr finalNoFree)
+
+nullFO :: ForeignPtr a
+nullFO = unsafePerformIO $ makeFO nullPtr nullFinaliser
+\end{code}
+
+\begin{code}
+readStablePtr :: Ptr (StablePtr a) -> IO (StablePtr a)
+readStablePtr ptr = peek ptr
+\end{code}
+
+Default by-value 'marshallers' for structs and unions.
+
+\begin{code}
+marshallStruct :: String -> a -> IO b
+marshallStruct nm _ = ioError (userError (nm ++ ": Marshalling structs by value is not supported yet."))
+
+unmarshallStruct :: String -> a -> IO c
+unmarshallStruct nm _ = ioError (userError (nm ++ ": Unmarshalling structs by value is not supported yet."))
+
+marshallUnion :: String -> a -> IO b
+marshallUnion nm _ = ioError (userError (nm ++ ": Marshalling unions by value is not supported yet."))
+
+unmarshallUnion :: String -> a -> b -> IO c
+unmarshallUnion nm _ _ = ioError (userError (nm ++ ": Unmarshalling unions by value is not supported yet."))
+\end{code}
+
+Ptr marshallers:
+
+\begin{code}
+marshallPointer :: Ptr a -> IO (Ptr a)
+marshallPointer p = return p
+
+unmarshallPointer :: Ptr a -> IO (Ptr a)
+unmarshallPointer ptr = return ptr --makeNoFreePtr ptr
+
+writePointer :: Ptr (Ptr a) -> Ptr a -> IO ()
+writePointer = poke
+
+readPointer :: Ptr (Ptr a) -> IO (Ptr a)
+readPointer ptr = peek ptr
+
+sizeofPtr :: Word32
+sizeofPtr  = fromIntegral (sizeOf (undefined :: Foreign.Ptr.Ptr ()))
+\end{code}
+
+\begin{code}
+primInvokeIt :: (Ptr b -> Ptr a -> IO c) -> Int -> IO (Ptr a) -> IO c
+primInvokeIt meth offset mk_obj_ptr = do
+  obj_ptr <- mk_obj_ptr 
+  lpVtbl  <- derefPtr (castPtr obj_ptr)
+  methPtr <- indexPtr lpVtbl offset
+  meth methPtr obj_ptr
+
+primInvokeItFO :: (Ptr b -> Ptr a -> IO c) -> Int -> IO (ForeignPtr a) -> IO c
+primInvokeItFO meth offset mk_obj_ptr = do
+  obj_ptr <- mk_obj_ptr
+  lpVtbl  <- peek (foreignPtrToPtr (castForeignPtr obj_ptr))
+  methPtr <- indexPtr lpVtbl offset
+  withForeignPtr obj_ptr (\ optr -> meth methPtr optr)
+\end{code}
+
+\begin{code}
+stackStringLen :: Int -> String -> (Ptr String -> IO a) -> IO a
+stackStringLen len str f
+      = let slen = length str + 1 `max` len
+        in stackFrame (fromIntegral slen) $ \pstr -> do 
+	 writeString False pstr str
+         f pstr
+
+\end{code}
+
+\begin{code}
+{- BEGIN_GHC_ONLY
+
+enumToFlag :: Enum a => a -> Int
+enumToFlag tg = fromIntegral ((1::Word32) `shiftL` enumToInt tg)
+
+enumToInt :: Enum a => a -> Int
+enumToInt tg = I# (getTag tg)
+
+flagToIntTag :: Int -> Int
+flagToIntTag f | f < 0     = error "flagToIntTag: negative tag"
+               | otherwise = go 0 f
+   -- could've used Prelude.logBase, but don't need the precision it offers.
+ where
+    go n 0 = n
+    go n 1 = n + 1
+    go n x = go (n + 1) (x `div` 2)
+
+unboxInt :: Int -> Int#
+unboxInt (I# x#) = x#
+
+toIntFlag :: Int -> Int -> Int
+toIntFlag b v = fromIntegral ((1::Word32) `shiftL` (v + flagToIntTag b))
+
+   END_GHC_ONLY -}
+
+pow2Series :: Int -> Int32 -> [Int32]
+pow2Series len start = take len (iterate double start)
+ where
+   double x
+     | x == 0    = 1
+     | otherwise = 2*x
+
+orList :: [Int] -> Int
+orList ls = fromIntegral (foldl (\ acc x -> (fromIntegral x) .|. acc) (0::Int32) ls)
+
+orFlags :: (Num a,Flags a) => [a] -> a
+orFlags ls = foldl (.+.) 0 ls
+
+class Flags a where
+  (.+.) :: a -> a -> a
+
+\end{code}
+ comlib/Makefile view
@@ -0,0 +1,330 @@+#
+# Makefile for HDirect Com library.
+#
+TOP = ..
+FOR_WIN32=YES
+include $(TOP)/mk/boilerplate.mk
+
+#
+# Should you want to build the library as a DLL, set it to NO.
+# (not supported with ghc-5.xx)
+#
+BUILD_STATICALLY=YES
+
+#
+# The Hugs98 version of the library is deposited in a separate directory, so
+# that it can coexist with the GHC version.
+#
+HUGSDIR=hugs
+
+#
+# The com library is a superset of the HDirect base library, but compiled differently
+# (i.e., it consistently uses the COM task allocator).
+# 
+HDLIBDIR =../lib
+
+HC_OPTS += -package-name com
+HC_OPTS	+= -package lang -I$(HDLIBDIR) -DCOM
+# Since we are using FFI exts we have to compile through C.
+HC_OPTS += -fglasgow-exts -fvia-C
+ifeq "$(BUILD_STATICALLY)" "YES"
+HC_OPTS += -static
+endif
+
+SRC_CC_OPTS += -I. -I$(HDLIBDIR) -DCOM
+
+all ::
+
+cpp_opts = -cpp -DBEGIN_GHC_ONLY='-}' -DEND_GHC_ONLY='{-' -DBEGIN_NOT_FOR_GHC='{-' -DEND_NOT_FOR_GHC='-}' -DELSE_FOR_GHC='-}-}' 
+
+HDirect_HC_OPTS += $(cpp_opts)
+Pointer_HC_OPTS += $(cpp_opts)
+Com_HC_OPTS          += $(cpp_opts)
+ComException_HC_OPTS += $(cpp_opts)
+ComPrim_HC_OPTS      += $(cpp_opts)
+Automation_HC_OPTS   += $(cpp_opts) -H12m -fno-warn-missing-methods -fno-warn-deprecations
+AutoPrim_HC_OPTS     += $(cpp_opts) -monly-3-regs
+WideString_HC_OPTS   += $(cpp_opts)
+ComServ_HC_OPTS      += $(cpp_opts)
+ComDll_HC_OPTS       += $(cpp_opts)
+SRC_MKDEPENDHS_OPTS  += $(cpp_opts)
+
+#
+# 5.04.2 is barfing when these are compiled with -O
+#
+EnumInterface_HC_OPTS += -Onot
+ClassFactory_HC_OPTS += -Onot
+
+SRC_IHC_OPTS         += -fno-qualified-names 
+HUGS_IHC_OPTS        = $(IHC_OPTS) --hugs -odir $(HUGSDIR)
+
+AutoPrim_IHC_OPTS    += -fno-imports -fno-export-lists -fhs-to-c  -fno-overload-variant -fout-pointers-are-not-refs -fsubtyped-interface-pointers
+ComPrim_IHC_OPTS     += -fno-imports -fno-export-lists -fout-pointers-are-not-refs
+WideString_IHC_OPTS  += -fno-imports -fno-export-lists -fkeep-hresult -fout-pointers-are-not-refs
+PointerPrim_IHC_OPTS += -fkeep-hresult -fout-pointers-are-not-refs
+StdTypes_IHC_OPTS    += -fno-export-list -fno-gen-variant-instances -fout-pointers-are-not-refs --gen-headers
+SafeArray_IHC_OPTS   += -fhs-to-c -fno-export-lists --gen-headers -fout-pointers-are-not-refs --gen-headers
+TypeLib_IHC_OPTS     += -fno-export-list -fappend-interface-short-name -fno-overload-variant --gen-headers
+Connection_IHC_OPTS  += -fappend-interface-short-name
+
+SafeArray_HC_OPTS    += -fvia-C '-\#include "SafeArray.h"'
+TypeLib_HC_OPTS      += -fvia-C
+Connection_HC_OPTS   += -fvia-C
+ComServ_HC_OPTS      += -fvia-C
+
+# Files that are part of both COM and non-COM builds.
+C_SRCS  = PointerSrc.c WideStringSrc.c
+H_SRCS  = $(HDLIBDIR)/HDirect.h $(HDLIBDIR)/PointerSrc.h $(HDLIBDIR)/WideStringSrc.h
+HS_SRCS = Pointer.lhs HDirect.lhs PointerPrim.hs WideString.hs
+
+COMLIB_C_SRCS    = ComPrimSrc.c AutoPrimSrc.c Registry.c SafeArrayPrim.c
+COMLIB_HS_SRCS   = Com.lhs Automation.lhs AutoPrim.hs ComPrim.hs StdTypes.hs
+COMLIB_HS_SRCS  += SafeArray.hs ComException.lhs
+COMLIB_HS_SRCS  += TypeLib.hs Connection.hs
+H_SRCS		+= comPrim.h autoPrim.h Registry.h safeArrayPrim.h SafeArray.h StdTypes.h
+
+C_SRCS   += $(COMLIB_C_SRCS)
+HS_SRCS  += $(COMLIB_HS_SRCS)
+
+C_OBJS  := $(subst PointerSrc.$(way_)o,PointerSrcCom.$(way_)o,$(C_OBJS))
+
+# for adding to SRC_DIST_FILES
+HUGS_EXTRA_SRCS =
+
+IDL_SRCS = $(wildcard *.idl)
+HUGS_IDL_SRCS = $(IDL_SRCS)
+
+
+#
+# The COM server specific modules are compilable under both
+# mingw32 and cygwin32, but there's a couple of niggling interop
+# issues with using cygwin32 DLLs from MSVC compiled code, so
+# it is recommended that you use mingw32 when you want to create
+# COM in-proc servers.
+#
+#
+COMLIB_EXTRA_HS_SRCS  += ComDll.lhs ComServ.lhs ClassFactory.lhs
+COMLIB_EXTRA_HS_SRCS  += StdDispatch.lhs ConnectionPoint.lhs
+COMLIB_EXTRA_HS_SRCS  += EnumInterface.lhs ExeServer.lhs
+
+HS_SRCS     += $(COMLIB_EXTRA_HS_SRCS)
+
+ifneq "$(USE_MSVC_TOOLS)" "YES"
+SRC_CC_OPTS += -mno-cygwin -I.
+endif
+
+SRCS = $(HS_SRCS) $(C_SRCS)
+
+SRC_DIST_FILES  = $(SRCS) $(H_SRCS) $(IDL_SRCS) $(HUGS_EXTRA_SRCS) Makefile com.pkg
+CLEAN_FILES += $(patsubst %.idl,%.hs,$(wildcard *.idl)) $(COPIED_OVER)
+
+#
+# 'make install' setup:
+#
+INSTALL_DATAS	= com.pkg $(HS_IFACES) $(SRCS)
+INSTALL_LIBS   += libHScom$(_way).a
+ifneq "$(BUILD_STATICALLY)" "YES"
+INSTALL_PROGS  += HScom.dll
+INSTALL_LIBS   += libHScom_imp.a
+endif
+
+#OBJS += $(patsubst %.idl, %.$(way_)o, $(IDL_SRCS))
+
+LIBCOM_OBJS += ComServ_stub.$(way_)o ClassFactory_stub.$(way_)o ComDll_stub.$(way_)o EnumInterface_stub.$(way_)o ConnectionPoint_stub.$(way_)o
+LIBCOM_OBJS += $(filter-out PointerSrc.$(way_)o, $(OBJS))
+
+all :: libHScom$(_way).a HScom.$(way_)o
+
+# We put the generated output for Hugs98 in a separate directory, $(HUGSDIR), so that
+# GHC and Hugs builds can coexist.
+all :: 
+	@if [ -d $(HUGSDIR) ]; then : ; else mkdir $(HUGSDIR); fi;
+
+clean :: 	
+	if [ -d $(HUGSDIR) ]; then $(RM) -rf $(HUGSDIR)/ ; else : ; fi;
+
+all :: $(patsubst %.idl, $(HUGSDIR)/%.hs, $(IDL_SRCS))
+
+all :: dlls
+
+$(HUGSDIR)/PointerPrim.c : $(HUGSDIR)/PointerPrim.hs
+$(HUGSDIR)/PointerPrim.$(STUB_OBJ_SUFFIX) : $(HUGSDIR)/PointerPrim.c
+
+$(HUGSDIR)/WideString.c : $(HUGSDIR)/WideString.hs
+$(HUGSDIR)/WideString.$(STUB_OBJ_SUFFIX) : $(HUGSDIR)/WideString.c
+
+$(HUGSDIR)/WideString.$(dllext) : $(HUGSDIR)/WideString.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/WideString.$(dllext) : $(HUGSDIR)/WideStringSrc.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/WideString.$(dllext) : HugsMod.def
+
+$(HUGSDIR)/PointerPrim.$(dllext) : $(HUGSDIR)/PointerPrim.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/PointerPrim.$(dllext) : $(HUGSDIR)/PointerSrcCom.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/PointerPrim.$(dllext) : HugsMod.def
+
+$(HUGSDIR)/AutoPrim.$(dllext) : $(HUGSDIR)/AutoPrimSrc.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/AutoPrim.$(dllext) : $(HUGSDIR)/AutoPrim.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/AutoPrim.$(dllext) : $(HUGSDIR)/PointerSrcCom.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/AutoPrim.$(dllext) : $(HUGSDIR)/ComPrimSrc.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/AutoPrim.$(dllext) : HugsMod.def
+
+$(HUGSDIR)/ComPrim.$(dllext) : HugsMod.def
+$(HUGSDIR)/ComPrim.$(dllext) : $(HUGSDIR)/ComPrim.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/ComPrim.$(dllext) : $(HUGSDIR)/ComPrimSrc.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/ComPrim.$(dllext) : $(HUGSDIR)/PointerSrcCom.$(STUB_OBJ_SUFFIX)
+
+$(HUGSDIR)/SafeArray.$(dllext) : $(HUGSDIR)/SafeArray.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/SafeArray.$(dllext) : $(HUGSDIR)/SafeArrayPrim.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/SafeArray.$(dllext) : HugsMod.def
+
+# StdTypes.idl doesn't generate a .c file, so filter it out.
+C_STUBS = $(patsubst %.idl, $(HUGSDIR)/%.c, $(filter-out StdTypes.idl, $(IDL_SRCS)))
+
+$(HUGSDIR)/%.hs: %.idl
+	$(IHC) $(HUGS_IHC_OPTS) -c $< -o $@
+
+$(HUGSDIR)/%.c: $(HUGSDIR)/%.hs
+	@:
+
+$(HUGSDIR)/%.$(STUB_OBJ_SUFFIX) : %.c
+	@$(RM) $@
+	$(CC) $(CC_OPTS) -c $< -o $@
+
+$(HUGSDIR)/%.$(STUB_OBJ_SUFFIX) : $(HUGSDIR)/%.c
+	@$(RM) $@
+	$(CC) $(CC_OPTS) -c $< -o $@
+
+ifeq "$(USE_MSVC_TOOLS)" "YES"
+$(HUGSDIR)/PointerSrcCom.$(STUB_OBJ_SUFFIX) : PointerSrc.c
+	@$(RM) $@
+	$(CCDLL) $(CCDLL_OPTS) -c -DCOM $< -Fo$@
+$(HUGSDIR)/%.obj : %.c
+	@$(RM) $@
+	$(CCDLL) $(CCDLL_OPTS) -c -DCOM $< -Fo$@
+$(HUGSDIR)/%.obj : $(HUGSDIR)/%.c
+	@$(RM) $@
+	$(CCDLL) $(CCDLL_OPTS) -c -DCOM $< -Fo$@
+else
+$(HUGSDIR)/PointerSrcCom.$(STUB_OBJ_SUFFIX) : PointerSrc.c
+	@$(RM) $@
+	$(CC) $(CC_OPTS) -c -DCOM $< -o $@
+endif
+
+.PRECIOUS: $(HUGSDIR)/%.$(STUB_OBJ_SUFFIX) $(HUGSDIR)/%.c $(HUGSDIR)/%.hs
+
+HugsMod.def :
+	@echo EXPORTS     > $@
+	@echo initModule >> $@
+
+COPIED_OVER=HDirect.lhs Pointer.lhs  WideString.idl PointerPrim.idl PointerSrc.c WideStringSrc.c
+
+HDirect.lhs : $(HDLIBDIR)/HDirect.lhs
+	$(CP) $< $@ 
+Pointer.lhs : $(HDLIBDIR)/Pointer.lhs
+	$(CP) $< $@ 
+WideString.idl : $(HDLIBDIR)/WideString.idl
+	$(CP) $< $@ 
+PointerPrim.idl : $(HDLIBDIR)/PointerPrim.idl
+	$(CP) $< $@ 
+PointerSrc.c : $(HDLIBDIR)/PointerSrc.c
+	$(CP) $< $@ 
+WideStringSrc.c : $(HDLIBDIR)/WideStringSrc.c
+	$(CP) $< $@ 
+
+$(HUGSDIR)/%.$(dllext) : $(HUGSDIR)/%.$(STUB_OBJ_SUFFIX)
+	$(CCDLL) $(CCDLL_OPTS) -o $@ $^ $(CCDLL_LIBS)
+
+dlls :: $(patsubst %.c, %.$(dllext), $(C_STUBS))
+
+HUGS_COMLIB_LHSS = HDirect.lhs Pointer.lhs Automation.lhs Com.lhs ComException.lhs
+
+all :: $(patsubst %.lhs,$(HUGSDIR)/%.lhs,$(HUGS_COMLIB_LHSS))
+
+$(HUGSDIR)/HDirect.lhs : HDirect.lhs
+	$(CP) $^ $(HUGSDIR)/
+
+$(HUGSDIR)/Pointer.lhs : Pointer.lhs
+	$(CP) $^ $(HUGSDIR)/
+
+$(HUGSDIR)/Automation.lhs : Automation.lhs
+	$(CP) $^ $(HUGSDIR)/
+
+$(HUGSDIR)/Com.lhs : Com.lhs
+	$(CP) $^ $(HUGSDIR)/
+
+$(HUGSDIR)/ComException.lhs : ComException.lhs
+	$(CP) $^ $(HUGSDIR)/
+
+
+# Configuration of hugslibdir is for local testing only; remove before releasing.
+ifeq "$(hugslibdir)" ""
+hugslibdir=c:/src/hugs98/lib
+endif
+
+install-hugs ::
+	mkdir -p $(hugslibdir)/hdirect
+	cp $(HUGSDIR)/*.$(dllext) $(hugslibdir)/hdirect
+	cp $(HUGSDIR)/*.hs $(hugslibdir)/hdirect
+	cp *.lhs $(hugslibdir)/hdirect
+
+# End of Hugs specific bit
+
+PointerSrcCom.$(way_)o : PointerSrc.c
+	@$(RM) $@
+	$(CC) $(CC_OPTS) -c -DCOM $< -o $@
+
+WideStringSrc.$(way_)o : WideStringSrc.c
+	@$(RM) $@
+	$(CC) $(CC_OPTS) -c -DCOM $< -o $@
+
+ComServ_stub.$(way_)o : ComServ.$(way_)o
+	@-
+
+ClassFactory_stub.$(way_)o : ClassFactory.$(way_)o
+	@-
+
+ComDll_stub.$(way_)o : ComDll.$(way_)o
+	@-
+
+EnumInterface_stub.$(way_)o : EnumInterface.$(way_)o
+	@-
+
+ConnectionPoint_stub.$(way_)o : ConnectionPoint.$(way_)o
+	@-
+
+libHScom$(_way).a : $(LIBCOM_OBJS)
+	$(RM) $@
+	$(AR) $(AR_OPTS) $@ $^
+
+HScom.$(way_)o: $(LIBCOM_OBJS)
+	$(LD) -r $(LD_X) -o $@ $(LIBCOM_OBJS)
+
+dll ::
+	$(HC) --mk-dll -o HScom.dll libHScom.a -fglasgow-exts -syslib lang -lwinmm -lole32 -loleaut32 -luser32 
+
+BOOT_SRCS=$(patsubst %.idl, %.hs, $(IDL_SRCS))
+boot :: $(COPIED_OVER) $(BOOT_SRCS)
+
+depend :: $(COPIED_OVER)
+
+include $(TOP)/mk/target.mk
+
+ifneq "$(BUILD_STATICALLY)" "YES"
+all :: dll
+endif
+
+.PHONY: install-pkg
+
+# ToDo: configure this approp. if you've installed the HDirect
+#       libraries first.
+ifeq "$(FOR_WIN32)" "YES"
+HDIRECT_LIBDIR=$(shell cygpath -p -w `pwd` | sed -e 's%\\%/%g')
+else
+HDIRECT_LIBDIR=$(shell pwd)
+endif
+
+ifeq "$(GHC_PKG)" ""
+GHC_PKG=ghc-pkg
+endif
+
+install-pkg: com.pkg
+	@hd_libdir="$(HDIRECT_LIBDIR)"  $(GHC_PKG) -u < com.pkg || echo "Unable to install 'com' package; try running ghc-pkg utility manually, i.e., \"ghc-pkg -u < com.pkg\""
+ comlib/Pointer.lhs view
@@ -0,0 +1,155 @@+
+Copyright (c) 1998,  Daan Leijen, leijen@@fwi.uva.nl
+
+This module is part of HaskellDirect (H/Direct).
+
+\begin{code}
+{-# OPTIONS -#include "PointerSrc.h" #-}
+module Pointer  
+	( 
+	  Ptr
+	
+	, allocMemory
+	, stackFrame
+
+	, writeSeqAtDec
+{-
+	, ptrInc
+	, writeSeqAt
+-}
+
+        , freeMemory
+	, freeBSTR
+	, freeWith
+	, freeWithC
+	
+	, primNoFree
+	
+	, finalNoFree
+	, finalFreeMemory
+	
+	, makeFO
+
+       ) where
+
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import PointerPrim
+import Word     ( Word32 )
+import Monad
+\end{code}
+
+The Pointer module provides helper functions over Ptrs +
+allocation/freeing of memory via malloc/free or the COM task
+allocator.
+
+\begin{code}
+type Finalizer a  = Ptr a -> IO ()
+
+makeFO :: Ptr a -> FunPtr (Ptr a -> IO ()) -> IO (ForeignPtr b)
+{- BEGIN_GHC_ONLY 
+#if __GLASGOW_HASKELL__ > 601
+makeFO obj finaliser = newForeignPtr (mkFinal finaliser obj) obj >>= return.castForeignPtr
+#else
+makeFO obj finaliser = newForeignPtr obj (mkFinal finaliser obj) >>= return.castForeignPtr
+#endif
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+-- Versionitis. If your version of Hugs is troubled by this one, simply enable the other version.
+makeFO obj finaliser = newForeignPtr (mkFinal finaliser obj) obj >>= return.castForeignPtr
+--makeFO obj finaliser = newForeignPtr obj (mkFinal finaliser obj) >>= return.castForeignPtr
+{- END_NOT_FOR_GHC -}
+
+{- BEGIN_GHC_ONLY
+#if __GLASGOW_HASKELL__ < 505
+mkFinal final obj = ap0 final obj
+foreign import ccall "dynamic" ap0 :: FunPtr (Ptr a -> IO()) -> (Ptr a -> IO ())
+#else
+mkFinal final _ = final
+#endif
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+mkFinal final _ = final
+{- END_NOT_FOR_GHC -}
+
+\end{code}
+
+Helpers.
+
+\begin{code}
+writeSeqAtDec :: Word32 -> [Ptr a -> IO ()] -> Ptr a -> IO ()
+writeSeqAtDec size ws ptr = go init_ptr ws
+  where
+   len           = fromIntegral (length ws - 1)
+   init_ptr      = ptr `plusPtr` (size_i * len)
+   size_i        = fromIntegral size
+
+   go _   []     = return ()
+   go ptr (x:xs) = do
+      x ptr
+      let ptr_next = ptr `plusPtr` (-size_i)
+      go ptr_next xs
+
+{-
+ptrInc i p        = p `plusAddr` (fromIntegral i)
+ptrDec d p        = p `plusAddr` (-(fromIntegral  d))
+
+writeSeqAt :: Word32 -> [Ptr a -> IO ()] -> Ptr a -> IO ()
+writeSeqAt size ws ptr = go ptr ws
+ where
+   go ptr []     = return ()
+   go ptr (x:xs) = do
+      x ptr
+      let ptr_next = ptrInc size ptr
+      go ptr_next xs
+-}
+
+\end{code}
+
+Use @stackFrame@ when you know the allocated chunk have
+a fixed extent.
+
+\begin{code}
+stackFrame :: Word32 -> (Ptr a -> IO b) -> IO b
+stackFrame size f
+      = do p <- allocMemory size
+           f p `always` primFreeMemory (castPtr p)
+
+\end{code}
+
+Special free routines for pointers. Use them to manually free pointers.
+
+\begin{code}
+freeMemory            = freeWithC primFreeMemory
+freeBSTR              = freeWithC primFreeBSTR
+
+freeWithC :: Finalizer () -> Ptr a -> IO ()
+freeWithC final p = final (castPtr p)
+
+freeWith :: (Ptr a -> IO ()) -> Ptr a -> IO ()
+freeWith free p = free p 
+\end{code}
+
+Helper functions that doesn't really have a good home to go to:
+
+\begin{code}
+always :: IO a -> IO () -> IO a
+always io action
+      = do x <- io `catch` (\ err -> do { action; ioError err })
+           action
+           return x
+
+\end{code}
+
+Primitives/helpers:
+
+\begin{code}
+allocMemory :: Word32 -> IO (Ptr a)
+allocMemory sz = do
+  a <- primAllocMemory sz
+  if a == nullPtr then
+     ioError (userError "allocMemory: not enough memory")
+   else
+     return (castPtr a)
+
+\end{code}
+ comlib/PointerPrim.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS -#include "PointerSrc.h" #-}
+-- Automatically generated by HaskellDirect (ihc.exe), version 0.20
+-- Created: 20:10 Pacific Standard Time, Tuesday 16 December, 2003
+-- Command line: -fno-qualified-names -fkeep-hresult -fout-pointers-are-not-refs -c PointerPrim.idl -o PointerPrim.hs
+
+module PointerPrim
+       ( primNoFree
+       , primFreeBSTR
+       , primFreeMemory
+       , finalNoFree
+       , finalFreeMemory
+       , primAllocMemory
+       , primFinalise
+       ) where
+       
+import Prelude
+import Foreign.Ptr (Ptr)
+import IOExts (unsafePerformIO)
+import Word (Word32)
+
+primNoFree :: Ptr ()
+           -> IO ()
+primNoFree p =
+  prim_PointerPrim_primNoFree p
+
+foreign import stdcall "primNoFree" prim_PointerPrim_primNoFree :: Ptr () -> IO ()
+primFreeBSTR :: Ptr ()
+             -> IO ()
+primFreeBSTR p =
+  prim_PointerPrim_primFreeBSTR p
+
+foreign import stdcall "primFreeBSTR" prim_PointerPrim_primFreeBSTR :: Ptr () -> IO ()
+primFreeMemory :: Ptr ()
+               -> IO ()
+primFreeMemory p =
+  prim_PointerPrim_primFreeMemory p
+
+foreign import stdcall "primFreeMemory" prim_PointerPrim_primFreeMemory :: Ptr () -> IO ()
+finalNoFree :: Ptr ()
+finalNoFree = unsafePerformIO (prim_PointerPrim_finalNoFree)
+
+foreign import stdcall "finalNoFree" prim_PointerPrim_finalNoFree :: IO (Ptr ())
+finalFreeMemory :: Ptr ()
+finalFreeMemory =
+  unsafePerformIO (prim_PointerPrim_finalFreeMemory)
+
+foreign import stdcall "finalFreeMemory" prim_PointerPrim_finalFreeMemory :: IO (Ptr ())
+primAllocMemory :: Word32
+                -> IO (Ptr ())
+primAllocMemory sz = prim_PointerPrim_primAllocMemory sz
+
+foreign import stdcall "primAllocMemory" prim_PointerPrim_primAllocMemory :: Word32 -> IO (Ptr ())
+primFinalise :: Ptr ()
+             -> Ptr ()
+             -> IO ()
+primFinalise finaliser finalisee =
+  prim_PointerPrim_primFinalise finaliser
+                                finalisee
+
+foreign import stdcall "primFinalise" prim_PointerPrim_primFinalise :: Ptr () -> Ptr () -> IO ()
+
+ comlib/PointerPrim.idl view
@@ -0,0 +1,21 @@+/*
+  Primitive pointer allocation/freeing 
+  functions.
+ */
+stub_include("PointerSrc.h");
+module PointerPrim {
+
+void primNoFree ([in,ptr]void* p);
+void primFreeBSTR ([in,ptr]void* p);
+void primFreeMemory ([in,ptr]void* p);
+
+[pure]void* finalNoFree();
+[pure]void* finalFreeMemory();
+
+[ptr]void* primAllocMemory([in]unsigned int sz);
+
+void  primFinalise( [in,ptr]void* finaliser
+		  , [in,ptr]void* finalisee);
+
+};
+
+ comlib/PointerSrc.c view
@@ -0,0 +1,149 @@+/* This stuff will eventually be replaced by calls to the
+   storage manager in the new GHC/Hugs RTS.   -- sof
+*/
+
+#if defined(__CYGWIN32__) || defined(__MINGW32__) || defined(__CYGWIN__)
+#define __BASTARDIZED_WIN32__ 1
+#endif
+
+/*-----------------------------------------------------------
+-- (c) 1998,  Daan Leijen, leijen@@fwi.uva.nl
+-----------------------------------------------------------*/
+/* #define DEBUG */
+
+/* if you don't use COM, comment this out */
+/* (pass the setting for this via command line instead.) */
+/* #define COM */
+
+/* define the DLL export macro */
+#if defined(_BASTARDIZED_WIN32__)
+#define DLLEXPORT(res)  __declspec(dllexport) res
+#else
+/* redef this default for your system */
+#define DLLEXPORT(res)  extern res
+#endif
+
+
+#ifdef COM
+#define COBJMACROS
+#define CINTERFACE
+#endif
+
+#include <stdio.h>
+
+#if !defined(__BASTARDIZED_WIN32__) && defined(COM)
+#include <windows.h>
+#else
+# if defined(__BASTARDIZED_WIN32__)
+  #include <windows.h>
+# if defined(__BASTARDIZED_WIN32__) && defined(COM)
+  #include "comPrim.h"
+# endif
+# endif
+#include <stdlib.h>
+#endif
+
+#ifdef DEBUG
+static int nallocs = 0;
+static int nallocs_ = 0;
+#endif
+
+void primPointerCheck(void)
+{
+#ifdef DEBUG
+    if (nallocs - nallocs_ != 0)
+      printf( "pointer errors: allocs - frees = %i\n", nallocs - nallocs_ );
+    nallocs_ = nallocs;
+#endif    
+}     
+
+/*-----------------------------------------------------------
+-- Free routines for foreign objects
+-----------------------------------------------------------*/
+
+DLLEXPORT(void) primFreeBSTR( void* p )
+{
+#ifdef COM
+   if (p) SysFreeString( (BSTR)p );
+#endif
+}
+
+DLLEXPORT(void) primNoFree( void* p )
+{
+#if 0
+ char    msg[200];
+ WCHAR* wmsg;
+ HRESULT hr;
+
+ sprintf(msg, "freeing: %p", p);
+ MessageBox(NULL, msg, "primNoFree", MB_OK );
+
+ hr = primGUIDToString(p, &wmsg);
+ if (SUCCEEDED(hr)) {
+    MessageBoxW(NULL, wmsg, L"primNoFree-clsid", MB_OK);
+ }
+#endif
+}
+
+void primFinalise (void* f, void* a)
+{ ((void (*)(void *))f)(a); } 
+
+
+/*-----------------------------------------------------------
+-- Memory allocation
+-----------------------------------------------------------*/
+
+DLLEXPORT(void*) primAllocMemory( int size )
+{
+#ifdef COM
+
+#ifdef DEBUG
+    void* p;
+    p = CoTaskMemAlloc( size );
+    printf("alloc: %p, size = %i\n", p, size );
+    if (p) nallocs++;
+    return p;
+#else
+    return CoTaskMemAlloc(size);
+#endif
+
+#else
+    return malloc(size);
+#endif
+}
+
+/* COM version of freeing */
+#ifdef COM
+DLLEXPORT(void) primFreeMemory( void* p )
+{
+ #ifdef DEBUG    
+   if (!p) printf( "freeing null pointer\n" );
+ #endif
+   if (!p) return;
+ #ifdef DEBUG
+   if (p) nallocs--;
+   printf( "free: %p\n", p);
+ #endif
+   CoTaskMemFree( p );
+}
+#endif
+
+#ifndef COM
+DLLEXPORT(void) primFreeMemory( void* p )
+{
+ #ifdef DEBUG    
+   if (!p) printf( "free null pointer\n" );
+ #endif
+
+   if (!p) return;
+
+   free(p);
+}
+#endif /* !COM */
+
+/* Strictly speaking, converting a function pointer to a void*
+   is not guaranteed to be information preserving in ANSI C.
+*/
+void* finalFreeMemory() { return (void*)&primFreeMemory; }
+void* finalNoFree()     { return (void*)&primNoFree;   }
+void* finalFreeBSTR()   { return (void*)&primFreeBSTR; }
+ comlib/Registry.c view
@@ -0,0 +1,254 @@+/*
+  Misc helper functions for accessing the registry.
+*/
+#include <windows.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "comPrim.h"
+
+#if __CYGWIN32__
+int wcslen(WCHAR* wstr)
+{
+  return WideCharToMultiByte(CP_ACP, WC_DEFAULTCHAR, wstr, (-1), NULL, 0, NULL, NULL);
+}
+#endif
+
+/* 
+ RegAddEntry() adds a key + string value at
+
+      HKEY_CLASSES_ROOT\path\subKey1\subKey2
+
+*/
+HRESULT
+RegAddEntry(int hive,
+	    const char* path,
+            const char* subKey1,
+            const char* subKey2,
+            const char* value)
+{
+   HKEY hKey;
+   char keyBuffer[1024]; /* Sigh! */
+   long result;
+   HANDLE the_hive;
+
+   switch(hive) {
+    case 0: the_hive = HKEY_CLASSES_ROOT; break;
+    case 1: the_hive = HKEY_CURRENT_USER; break;
+    case 2: the_hive = HKEY_LOCAL_MACHINE; break;
+    case 3: the_hive = HKEY_USERS; break;
+    case 4: the_hive = HKEY_CURRENT_CONFIG; break;
+   default:
+     MessageBox (NULL, "RegAddEntry: weird hive", "RegAddEntry", MB_OK | MB_ICONINFORMATION );
+     return E_FAIL;
+   }
+
+   /* construct complete path in buffer. */
+   strcpy(keyBuffer, path) ;
+   if (subKey1 != NULL) {
+	strcat(keyBuffer, "\\") ;
+	strcat(keyBuffer, subKey1 ) ;
+   }
+
+   if (subKey2 != NULL) {
+	strcat(keyBuffer, "\\") ;
+	strcat(keyBuffer, subKey2 ) ;
+   }
+
+   /* Create and open key and subkey. */
+   result = RegCreateKeyEx(the_hive,
+	                   keyBuffer, 
+	                   0, NULL, REG_OPTION_NON_VOLATILE,
+	                   KEY_ALL_ACCESS, NULL, 
+	                   &hKey, NULL) ;
+   if (result != ERROR_SUCCESS) {
+	return S_FALSE;
+   }
+
+   /* Set the value */
+   if (value != NULL) {
+      RegSetValueEx(hKey, NULL, 0, REG_SZ, 
+	            (BYTE *)value, 
+	            strlen(value)+1) ;
+   }
+
+   RegCloseKey(hKey) ;
+   return S_OK;
+}
+
+/* Called by Haskell code */
+HRESULT
+primRegAddEntry ( int hive, const char* path, const char* val)
+{
+ return RegAddEntry( hive, path, NULL, NULL, val);
+}
+
+#define REMOVE_KEY    1
+#define REMOVE_VALUE  0
+
+/*
+ RegRemoveEntry() adds a key + string value at
+
+      HKEY_CLASSES_ROOT\path\subKey1\subKey2
+*/
+HRESULT
+RegRemoveEntry
+         ( int hive
+	 , const char* path
+         , const char* subKey1
+	 , const char* subKey2
+	 , int deleteKey
+	 )
+{
+   HKEY hKey;
+   LONG res;
+   char keyBuffer[1024]; /* Sigh! */
+   HANDLE the_hive;
+
+   switch(hive) {
+    case 0: the_hive = HKEY_CLASSES_ROOT; break;
+    case 1: the_hive = HKEY_CURRENT_USER; break;
+    case 2: the_hive = HKEY_LOCAL_MACHINE; break;
+    case 3: the_hive = HKEY_USERS; break;
+    case 4: the_hive = HKEY_CURRENT_CONFIG; break;
+   default:
+     MessageBox (NULL, "RegAddEntry: weird hive", "RegAddEntry", MB_OK | MB_ICONINFORMATION );
+     return E_FAIL;
+   }
+
+   /* construct complete path in buffer. */
+   strcpy(keyBuffer, path);
+
+   if (subKey1 != NULL) {
+	strcat(keyBuffer, "\\") ;
+	strcat(keyBuffer, subKey1 ) ;
+   }
+
+   res = RegOpenKeyEx 
+             ( the_hive
+	     , keyBuffer
+	     , 0
+	     , KEY_SET_VALUE
+	     , &hKey
+	     );
+   if ( res != ERROR_SUCCESS ) {
+     MessageBox (NULL, "RegOpenKeyEx() failed", "RegRemoveEntry", MB_OK | MB_ICONINFORMATION );
+     return S_FALSE;
+   }
+   if ( deleteKey ) {
+     res = RegDeleteKey (hKey, subKey2 );
+   } else {
+     res = RegDeleteValue (hKey, subKey2 );
+   }
+   RegCloseKey(hKey) ;
+   return ( res == ERROR_SUCCESS ? S_OK : S_FALSE );
+}
+
+/* Called by Haskell code */
+HRESULT
+primRegRemoveEntry ( int hive, const char* path, const char* val, int kind)
+{
+ return RegRemoveEntry( hive, path, NULL, val, kind);
+}
+
+#if 0
+HRESULT
+RegisterServer ( HMODULE  hMod
+	       , REFCLSID rclsid
+	       , const char* name
+	       , const char* verProgID
+	       , const char* progID
+	       )
+{
+   char    modBuffer[1024]; /* Sigh! */
+   WCHAR   wstr[45];
+   char*   clsid_str;
+   DWORD   st;
+   int     i;
+   HRESULT hr;
+
+   st = GetModuleFileName (hMod, modBuffer, 1024);
+
+   if ( st == 0 ) {
+     MessageBox (NULL, "GetModuleFileName() failed", "Msg", MB_OK | MB_ICONINFORMATION );
+     return S_FALSE;
+   }
+
+   i = StringFromGUID2 ( rclsid, wstr, 45);
+   if (i == 0) {
+     MessageBox (NULL, "StringFromGUID2() failed", "RegisterServer", MB_OK | MB_ICONINFORMATION );
+     return S_FALSE;
+   }
+   clsid_str = (char*)malloc((wcslen(wstr)+1)*sizeof(char));
+   UNI2STR(clsid_str,wstr);
+
+   /* 
+      HKCR\CLSID\{clsid}\{name}
+      HKCR\CLSID\{clsid}\InProcServer32\{dll-name}
+      HKCR\CLSID\{clsid}\ProgId\{prog-id}
+      HKCR\CLSID\{clsid}\VersionIndependentProgId\{vprog-id}
+
+      HKCR\{prog-id}\CLSID\{clsid}
+      HKCR\{vprog-id}\CLSID\{clsid}
+
+   */
+   hr = RegAddEntry(0, "CLSID", clsid_str , "", name);
+   if (FAILED(hr)) return hr;
+   hr = RegAddEntry(0, "CLSID", clsid_str , "InprocServer32", modBuffer);
+   if (FAILED(hr)) return hr;
+   hr = RegAddEntry(0, "CLSID", clsid_str , "ProgID", progID);
+   if (FAILED(hr)) return hr;
+   hr = RegAddEntry(0, "CLSID", clsid_str , "VersionIndependentProgID", verProgID);
+   if (FAILED(hr)) return hr;
+   hr = RegAddEntry(0, progID, "CLSID", NULL, clsid_str);
+   if (FAILED(hr)) return hr;
+   hr = RegAddEntry(0, verProgID, "CLSID", NULL, clsid_str);
+   if (FAILED(hr)) return hr;
+
+   return S_OK;   
+}
+#endif
+
+#if 0
+HRESULT
+UnregisterServer 
+               ( HMODULE  hMod
+	       , REFCLSID rclsid
+	       , const char* name
+	       , const char* verProgID
+	       , const char* progID
+	       )
+{ 
+   char    modBuffer[1024]; /* Sigh! */
+   WCHAR   wstr[45];
+   char*   clsid_str;
+   DWORD   st;
+   int     i;
+   HRESULT hr;
+
+   st = GetModuleFileName (hMod, modBuffer, 1024);
+
+   if ( st == 0 ) {
+     MessageBox (NULL, "GetModuleFileName() failed", "Msg", MB_OK | MB_ICONINFORMATION );
+     return S_FALSE;
+   }
+
+   i = StringFromGUID2 ( rclsid, wstr, 45);
+   if (i == 0) {
+     MessageBox (NULL, "StringFromGUID2() failed", "RegisterServer", MB_OK | MB_ICONINFORMATION );
+     return S_FALSE;
+   }
+   clsid_str = (char*)malloc((wcslen(wstr)+1)*sizeof(char));
+   UNI2STR(clsid_str,wstr);
+
+   hr = RegRemoveEntry(0, "CLSID", clsid_str , "InprocServer32", REMOVE_KEY);
+   if (FAILED(hr)) return hr;
+   hr = RegRemoveEntry(0, "CLSID", clsid_str , "ProgID", REMOVE_KEY);
+   if (FAILED(hr)) return hr;
+   hr = RegRemoveEntry(0, "CLSID", clsid_str , "VersionIndependentProgID", REMOVE_KEY);
+   if (FAILED(hr)) return hr;
+   hr = RegRemoveEntry(0, "CLSID", NULL , clsid_str, REMOVE_KEY);
+   if (FAILED(hr)) return hr;
+   return S_OK;
+}
+#endif
+ comlib/Registry.h view
@@ -0,0 +1,34 @@+#ifndef __REGISTRY_H__
+#define __REGISTRY_H__
+
+extern
+HRESULT
+primRegAddEntry ( int hive, const char* path, const char* val);
+
+extern
+HRESULT
+primRegRemoveEntry ( int hive, const char* path, const char* val, int kind);
+
+#if 0
+extern
+HRESULT
+RegisterServer ( HMODULE  hMod
+	       , REFCLSID rclsid
+	       , const char* name
+	       , const char* verProgID
+	       , const char* progID
+	       );
+extern
+HRESULT
+UnregisterServer 
+               ( HANDLE hMod
+	       , REFCLSID rclsid
+	       , const char* name
+	       , const char* verProgID
+	       , const char* progID
+	       );
+
+#endif
+
+
+#endif
+ comlib/SafeArray.h view
@@ -0,0 +1,73 @@+/*
+Automatically generated by HaskellDirect (ihc.exe), version 0.20
+Created: 20:11 Pacific Standard Time, Tuesday 16 December, 2003
+Command line: -fno-qualified-names -fhs-to-c -fno-export-lists --gen-headers -fout-pointers-are-not-refs --gen-headers -c SafeArray.idl -o SafeArray.hs
+*/
+
+
+#ifndef __INT64_DEFINED__
+#ifdef __GNUC__
+typedef long long int64;
+typedef unsigned long long uint64;
+#else
+#ifdef _MSC_VER
+typedef __int64 int64;
+typedef unsigned __int64 uint64;
+#else
+/* Need some help here, please. */
+#endif
+#endif
+#define __INT64_DEFINED__
+#endif
+
+
+#ifndef __SAFEARRAY_H__
+#define __SAFEARRAY_H__
+#if defined(__MINGW32__) || defined(__CYGWIN32__)
+#include <w32api.h>
+#endif
+#if !defined(_MSC_VER) && __W32API_MAJOR_VERSION == 1
+typedef struct SAFEARRAY *SAFEARRAY;
+typedef struct tagSAFEARRAYBOUND {
+           unsigned long cElements;
+           long lLbound;
+        } SAFEARRAYBOUND;
+extern HRESULT __stdcall SafeArrayAccessData ( /*[in, ptr]*/SAFEARRAY* psa
+                                             , /*[out, ref]*/void** ppvData );
+extern HRESULT __stdcall SafeArrayAllocData ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayAllocDescriptor ( /*[in]*/unsigned long cDims
+                                                  , /*[out]*/SAFEARRAY** ppsaOut );
+extern HRESULT __stdcall SafeArrayCopy ( /*[in, ptr]*/SAFEARRAY* psa
+                                       , /*[out]*/SAFEARRAY** ppsaOut );
+/*[ref, finaliser("primSafeArrayDestroy"), finaliser("primSafeArrayDestroy"), ref, ref]*/
+extern SAFEARRAY* __stdcall SafeArrayCreate ( /*[in]*/unsigned short vt
+                                            , /*[in]*/unsigned long cDims
+                                            , /*[in, size_is(cDims)]*/SAFEARRAYBOUND* rgsabound );
+extern HRESULT __stdcall SafeArrayDestroy ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayDestroyData ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayDestroyDescriptor ( /*[in, ptr]*/SAFEARRAY* psa );
+extern unsigned long __stdcall SafeArrayGetDim ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayGetElement ( /*[in, ptr]*/SAFEARRAY* psa
+                                             , /*[in, ptr]*/long* rgIndices
+                                             , /*[in, ptr]*/void* pv );
+extern unsigned long __stdcall SafeArrayGetElemsize ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayGetLBound ( /*[in, ptr]*/SAFEARRAY* psa
+                                            , /*[in]*/unsigned long nDim
+                                            , /*[out]*/long* plLbound );
+extern HRESULT __stdcall SafeArrayGetUBound ( /*[in, ptr]*/SAFEARRAY* psa
+                                            , /*[in]*/unsigned long nDim
+                                            , /*[out]*/long* plLbound );
+extern HRESULT __stdcall SafeArrayLock ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayPtrOfIndex ( /*[in, ptr]*/SAFEARRAY* psa
+                                             , /*[in, ptr]*/long* rgIndices
+                                             , /*[out]*/void** ppvData );
+extern HRESULT __stdcall SafeArrayPutElement ( /*[in, ptr]*/SAFEARRAY* psa
+                                             , /*[in, ptr]*/long* rgIndices
+                                             , /*[in, ptr]*/void* pv );
+extern HRESULT __stdcall SafeArrayRedim ( /*[in, ptr]*/SAFEARRAY* psa
+                                        , /*[in, ref]*/SAFEARRAYBOUND* psaboundNew );
+extern HRESULT __stdcall SafeArrayUnaccessData ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayUnlock ( /*[in, ptr]*/SAFEARRAY* psa );
+#endif
+
+#endif
+ comlib/SafeArray.hs view
@@ -0,0 +1,315 @@+{-# OPTIONS -#include <windows.h> #-}
+{-# OPTIONS -#include "SafeArrayPrim.h" #-}
+-- Automatically generated by HaskellDirect (ihc.exe), version 0.20
+-- Created: 20:11 Pacific Standard Time, Tuesday 16 December, 2003
+-- Command line: -fno-qualified-names -fhs-to-c -fno-export-lists --gen-headers -fout-pointers-are-not-refs --gen-headers -c SafeArray.idl -o SafeArray.hs
+
+module SafeArray where
+
+import Prelude
+import Com (checkHR)
+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
+import Foreign.Ptr (Ptr, FunPtr, castPtr)
+import HDirect (nullFinaliser, writefptr, readPtr, sizeofPtr, 
+                writeWord32, writeInt32, addNCastPtr, readWord32, readInt32, 
+                allocBytes, free, doThenFree, sizeofForeignPtr, marshalllist, 
+                trivialFree, freeref, sizeofInt32, marshallref)
+import IOExts (unsafePerformIO)
+import Int (Int32)
+import Pointer (makeFO)
+import StdTypes (VARTYPE)
+import Word (Word32, Word16)
+
+{- BEGIN_C_CODE
+#if defined(__MINGW32__) || defined(__CYGWIN32__)
+END_C_CODE-}
+{- BEGIN_C_CODE
+#include <w32api.h>
+END_C_CODE-}
+{- BEGIN_C_CODE
+#endif
+END_C_CODE-}
+{- BEGIN_C_CODE
+#if !defined(_MSC_VER) && __W32API_MAJOR_VERSION == 1
+END_C_CODE-}
+-- --------------------------------------------------
+-- 
+-- interface SAFEARRAY
+-- 
+-- --------------------------------------------------
+newtype SAFEARRAY
+ = SAFEARRAY (ForeignPtr SAFEARRAY)
+ 
+foreign label "primSafeArrayDestroy" addrOf_SAFEARRAY_primSafeArrayDestroy :: FunPtr (Ptr SAFEARRAY -> IO ())
+marshallSAFEARRAY :: SAFEARRAY
+                  -> IO (ForeignPtr SAFEARRAY)
+marshallSAFEARRAY (SAFEARRAY v) = return (v)
+
+unmarshallSAFEARRAY :: Bool
+                    -> Ptr SAFEARRAY
+                    -> IO SAFEARRAY
+unmarshallSAFEARRAY finaliseMe__ v =
+  do
+    v <- makeFO v (case finaliseMe__ of
+                      False -> nullFinaliser
+                      True -> addrOf_SAFEARRAY_primSafeArrayDestroy)
+    return (SAFEARRAY v)
+
+writeSAFEARRAY :: Ptr (Ptr SAFEARRAY)
+               -> SAFEARRAY
+               -> IO ()
+writeSAFEARRAY ptr (SAFEARRAY v) =
+  writefptr ptr
+            v
+
+readSAFEARRAY :: Bool
+              -> Ptr SAFEARRAY
+              -> IO SAFEARRAY
+readSAFEARRAY finaliseMe__ ptr =
+  do
+    v <- readPtr ptr
+    v <- makeFO v (case finaliseMe__ of
+                      False -> nullFinaliser
+                      True -> addrOf_SAFEARRAY_primSafeArrayDestroy)
+    return (SAFEARRAY v)
+
+sizeofSAFEARRAY :: Word32
+sizeofSAFEARRAY = sizeofPtr
+
+addrToSAFEARRAY :: Ptr a
+                -> SAFEARRAY
+addrToSAFEARRAY v =
+  unsafePerformIO (makeFO (castPtr v) addrOf_SAFEARRAY_primSafeArrayDestroy >>= \ v ->
+                   return (SAFEARRAY v))
+
+data SAFEARRAYBOUND = TagSAFEARRAYBOUND {cElements :: Word32,
+                                         lLbound :: Int32}
+                        
+writeSAFEARRAYBOUND :: Ptr SAFEARRAYBOUND
+                    -> SAFEARRAYBOUND
+                    -> IO ()
+writeSAFEARRAYBOUND ptr (TagSAFEARRAYBOUND cElements lLbound) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 cElements
+    let pf2 = addNCastPtr pf1 4
+    writeInt32 pf2 lLbound
+
+readSAFEARRAYBOUND :: Ptr SAFEARRAYBOUND
+                   -> IO SAFEARRAYBOUND
+readSAFEARRAYBOUND ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    cElements <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    lLbound <- readInt32 pf2
+    return (TagSAFEARRAYBOUND cElements lLbound)
+
+sizeofSAFEARRAYBOUND :: Word32
+sizeofSAFEARRAYBOUND = 8
+
+safeArrayAccessData :: SAFEARRAY
+                    -> IO (Ptr ())
+safeArrayAccessData psa =
+  do
+    ppvData <- allocBytes (fromIntegral sizeofPtr)
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayAccessData <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayAccessData psa ppvData)
+    checkHR o_safeArrayAccessData
+    doThenFree free readPtr ppvData
+
+foreign import stdcall "SafeArrayAccessData" prim_SafeArray_safeArrayAccessData :: Ptr SAFEARRAY -> Ptr (Ptr ()) -> IO Int32
+safeArrayAllocData :: SAFEARRAY
+                   -> IO ()
+safeArrayAllocData psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayAllocData <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayAllocData psa)
+    checkHR o_safeArrayAllocData
+
+foreign import stdcall "SafeArrayAllocData" prim_SafeArray_safeArrayAllocData :: Ptr SAFEARRAY -> IO Int32
+safeArrayAllocDescriptor :: Word32
+                         -> IO SAFEARRAY
+safeArrayAllocDescriptor cDims =
+  do
+    ppsaOut <- allocBytes (fromIntegral sizeofForeignPtr)
+    o_safeArrayAllocDescriptor <- prim_SafeArray_safeArrayAllocDescriptor cDims ppsaOut
+    checkHR o_safeArrayAllocDescriptor
+    doThenFree free (readSAFEARRAY True) ppsaOut
+
+foreign import stdcall "SafeArrayAllocDescriptor" prim_SafeArray_safeArrayAllocDescriptor :: Word32 -> Ptr (Ptr SAFEARRAY) -> IO Int32
+safeArrayCopy :: SAFEARRAY
+              -> IO SAFEARRAY
+safeArrayCopy psa =
+  do
+    ppsaOut <- allocBytes (fromIntegral sizeofForeignPtr)
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayCopy <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayCopy psa ppsaOut)
+    checkHR o_safeArrayCopy
+    doThenFree free (readSAFEARRAY True) ppsaOut
+
+foreign import stdcall "SafeArrayCopy" prim_SafeArray_safeArrayCopy :: Ptr SAFEARRAY -> Ptr (Ptr SAFEARRAY) -> IO Int32
+safeArrayCreate :: VARTYPE
+                -> [SAFEARRAYBOUND]
+                -> IO SAFEARRAY
+safeArrayCreate vt rgsabound =
+  let
+   cDims = (fromIntegral (length rgsabound) :: Word32)
+  in
+  do
+    rgsabound <- marshalllist sizeofSAFEARRAYBOUND writeSAFEARRAYBOUND rgsabound
+    o_safeArrayCreate <- prim_SafeArray_safeArrayCreate vt cDims rgsabound
+    freeref trivialFree rgsabound
+    unmarshallSAFEARRAY True o_safeArrayCreate
+
+foreign import stdcall "SafeArrayCreate" prim_SafeArray_safeArrayCreate :: Word16 -> Word32 -> Ptr SAFEARRAYBOUND -> IO (Ptr SAFEARRAY)
+safeArrayDestroy :: SAFEARRAY
+                 -> IO ()
+safeArrayDestroy psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayDestroy <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayDestroy psa)
+    checkHR o_safeArrayDestroy
+
+foreign import stdcall "SafeArrayDestroy" prim_SafeArray_safeArrayDestroy :: Ptr SAFEARRAY -> IO Int32
+safeArrayDestroyData :: SAFEARRAY
+                     -> IO ()
+safeArrayDestroyData psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayDestroyData <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayDestroyData psa)
+    checkHR o_safeArrayDestroyData
+
+foreign import stdcall "SafeArrayDestroyData" prim_SafeArray_safeArrayDestroyData :: Ptr SAFEARRAY -> IO Int32
+safeArrayDestroyDescriptor :: SAFEARRAY
+                           -> IO ()
+safeArrayDestroyDescriptor psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayDestroyDescriptor <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayDestroyDescriptor psa)
+    checkHR o_safeArrayDestroyDescriptor
+
+foreign import stdcall "SafeArrayDestroyDescriptor" prim_SafeArray_safeArrayDestroyDescriptor :: Ptr SAFEARRAY -> IO Int32
+safeArrayGetDim :: SAFEARRAY
+                -> IO Word32
+safeArrayGetDim psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayGetDim psa)
+
+foreign import stdcall "SafeArrayGetDim" prim_SafeArray_safeArrayGetDim :: Ptr SAFEARRAY -> IO Word32
+safeArrayGetElement :: SAFEARRAY
+                    -> Ptr Int32
+                    -> Ptr ()
+                    -> IO ()
+safeArrayGetElement psa rgIndices pv =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayGetElement <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayGetElement psa rgIndices pv)
+    checkHR o_safeArrayGetElement
+
+foreign import stdcall "SafeArrayGetElement" prim_SafeArray_safeArrayGetElement :: Ptr SAFEARRAY -> Ptr Int32 -> Ptr () -> IO Int32
+safeArrayGetElemsize :: SAFEARRAY
+                     -> IO Word32
+safeArrayGetElemsize psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayGetElemsize psa)
+
+foreign import stdcall "SafeArrayGetElemsize" prim_SafeArray_safeArrayGetElemsize :: Ptr SAFEARRAY -> IO Word32
+safeArrayGetLBound :: SAFEARRAY
+                   -> Word32
+                   -> IO Int32
+safeArrayGetLBound psa nDim =
+  do
+    plLbound <- allocBytes (fromIntegral sizeofInt32)
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayGetLBound <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayGetLBound psa nDim plLbound)
+    checkHR o_safeArrayGetLBound
+    doThenFree free readInt32 plLbound
+
+foreign import stdcall "SafeArrayGetLBound" prim_SafeArray_safeArrayGetLBound :: Ptr SAFEARRAY -> Word32 -> Ptr Int32 -> IO Int32
+safeArrayGetUBound :: SAFEARRAY
+                   -> Word32
+                   -> IO Int32
+safeArrayGetUBound psa nDim =
+  do
+    plLbound <- allocBytes (fromIntegral sizeofInt32)
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayGetUBound <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayGetUBound psa nDim plLbound)
+    checkHR o_safeArrayGetUBound
+    doThenFree free readInt32 plLbound
+
+foreign import stdcall "SafeArrayGetUBound" prim_SafeArray_safeArrayGetUBound :: Ptr SAFEARRAY -> Word32 -> Ptr Int32 -> IO Int32
+safeArrayLock :: SAFEARRAY
+              -> IO ()
+safeArrayLock psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayLock <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayLock psa)
+    checkHR o_safeArrayLock
+
+foreign import stdcall "SafeArrayLock" prim_SafeArray_safeArrayLock :: Ptr SAFEARRAY -> IO Int32
+safeArrayPtrOfIndex :: SAFEARRAY
+                    -> Ptr Int32
+                    -> IO (Ptr ())
+safeArrayPtrOfIndex psa rgIndices =
+  do
+    ppvData <- allocBytes (fromIntegral sizeofPtr)
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayPtrOfIndex <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayPtrOfIndex psa rgIndices ppvData)
+    checkHR o_safeArrayPtrOfIndex
+    doThenFree free readPtr ppvData
+
+foreign import stdcall "SafeArrayPtrOfIndex" prim_SafeArray_safeArrayPtrOfIndex :: Ptr SAFEARRAY -> Ptr Int32 -> Ptr (Ptr ()) -> IO Int32
+safeArrayPutElement :: SAFEARRAY
+                    -> Ptr Int32
+                    -> Ptr ()
+                    -> IO ()
+safeArrayPutElement psa rgIndices pv =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayPutElement <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayPutElement psa rgIndices pv)
+    checkHR o_safeArrayPutElement
+
+foreign import stdcall "SafeArrayPutElement" prim_SafeArray_safeArrayPutElement :: Ptr SAFEARRAY -> Ptr Int32 -> Ptr () -> IO Int32
+safeArrayRedim :: SAFEARRAY
+               -> SAFEARRAYBOUND
+               -> IO ()
+safeArrayRedim psa psaboundNew =
+  do
+    psa <- marshallSAFEARRAY psa
+    psaboundNew <- marshallref (allocBytes (fromIntegral sizeofSAFEARRAYBOUND)) writeSAFEARRAYBOUND psaboundNew
+    o_safeArrayRedim <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayRedim psa psaboundNew)
+    free psaboundNew
+    checkHR o_safeArrayRedim
+
+foreign import stdcall "SafeArrayRedim" prim_SafeArray_safeArrayRedim :: Ptr SAFEARRAY -> Ptr SAFEARRAYBOUND -> IO Int32
+safeArrayUnaccessData :: SAFEARRAY
+                      -> IO ()
+safeArrayUnaccessData psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayUnaccessData <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayUnaccessData psa)
+    checkHR o_safeArrayUnaccessData
+
+foreign import stdcall "SafeArrayUnaccessData" prim_SafeArray_safeArrayUnaccessData :: Ptr SAFEARRAY -> IO Int32
+safeArrayUnlock :: SAFEARRAY
+                -> IO ()
+safeArrayUnlock psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayUnlock <- withForeignPtr psa (\ psa -> prim_SafeArray_safeArrayUnlock psa)
+    checkHR o_safeArrayUnlock
+
+foreign import stdcall "SafeArrayUnlock" prim_SafeArray_safeArrayUnlock :: Ptr SAFEARRAY -> IO Int32
+{- BEGIN_C_CODE
+#endif
+END_C_CODE-}
+
+ comlib/SafeArray.idl view
@@ -0,0 +1,150 @@+stub_include <windows.h>;
+stub_include "SafeArrayPrim.h";
+module SafeArray {
+
+import "StdTypes.idl";
+
+cpp_quote("#if defined(__MINGW32__) || defined(__CYGWIN32__)")
+cpp_quote("#include <w32api.h>")
+cpp_quote("#endif")
+cpp_quote("#if !defined(_MSC_VER) && __W32API_MAJOR_VERSION == 1")
+[finaliser("primSafeArrayDestroy")]
+interface SAFEARRAY {};
+
+typedef struct tagSAFEARRAYBOUND {
+	unsigned long cElements;
+	long lLbound;
+} SAFEARRAYBOUND;
+
+HRESULT _stdcall
+SafeArrayAccessData
+		( [in,ptr]SAFEARRAY* psa
+		, [out,ref]void** ppvData
+		);
+
+HRESULT _stdcall
+SafeArrayAllocData
+		( [in,ptr]SAFEARRAY* psa
+		);
+
+HRESULT _stdcall
+SafeArrayAllocDescriptor
+		( [in]unsigned int cDims
+		, [out]SAFEARRAY** ppsaOut
+		);
+
+HRESULT _stdcall
+SafeArrayCopy
+		( [in,ptr]SAFEARRAY* psa
+		, [out]SAFEARRAY** ppsaOut
+		);
+
+/*
+HRESULT _stdcall
+SafeArrayCopyData
+		( [in,ptr]SAFEARRAY* psaSource
+		, [in,out]SAFEARRAY** psaTarget
+		);
+*/
+
+[ref]
+SAFEARRAY
+_stdcall
+*SafeArrayCreate
+		( [in]VARTYPE vt
+		, [in]unsigned int cDims
+		, [in,size_is(cDims)]SAFEARRAYBOUND* rgsabound
+		);
+
+/*
+HRESULT _stdcall
+SafeArrayCreateVector
+		( [in]VARTYPE vt
+		, [in]long lLbound
+		, [in]unsigned int cElements
+		);
+*/
+HRESULT _stdcall
+SafeArrayDestroy
+		( [in,ptr]SAFEARRAY* psa
+		);
+
+HRESULT _stdcall
+SafeArrayDestroyData
+		( [in,ptr]SAFEARRAY* psa
+		);
+
+HRESULT _stdcall
+SafeArrayDestroyDescriptor
+		( [in,ptr]SAFEARRAY* psa
+		);
+
+unsigned int _stdcall
+SafeArrayGetDim
+		( [in,ptr]SAFEARRAY* psa
+		);
+
+HRESULT _stdcall
+SafeArrayGetElement
+		( [in,ptr]SAFEARRAY* psa
+		//Ideally:, [in,size_is(psa->cDims-1)]long* rgIndices
+		, [in,ptr]long* rgIndices
+		, [in,ptr]void* pv
+		);
+
+unsigned int _stdcall
+SafeArrayGetElemsize
+		( [in,ptr]SAFEARRAY* psa
+		);
+
+HRESULT _stdcall
+SafeArrayGetLBound
+		( [in,ptr]SAFEARRAY* psa
+		, [in]unsigned int nDim
+		, [out]long* plLbound
+		);
+
+HRESULT _stdcall
+SafeArrayGetUBound
+		( [in,ptr]SAFEARRAY* psa
+		, [in]unsigned int nDim
+		, [out]long* plLbound
+		);
+
+HRESULT _stdcall
+SafeArrayLock
+		( [in,ptr]SAFEARRAY* psa
+		);
+
+HRESULT _stdcall
+SafeArrayPtrOfIndex
+		( [in,ptr]SAFEARRAY* psa
+		, [in,ptr]long* rgIndices
+		, [out]void** ppvData
+		);
+
+HRESULT _stdcall
+SafeArrayPutElement
+		( [in,ptr]SAFEARRAY* psa
+		, [in,ptr]long* rgIndices
+		, [in,ptr]void* pv
+		);
+
+HRESULT _stdcall
+SafeArrayRedim
+		( [in,ptr]SAFEARRAY* psa
+		, [in,ref]SAFEARRAYBOUND* psaboundNew
+		);
+
+HRESULT _stdcall
+SafeArrayUnaccessData
+		( [in,ptr]SAFEARRAY* psa
+		);
+
+HRESULT _stdcall
+SafeArrayUnlock
+		( [in,ptr]SAFEARRAY* psa
+		);
+
+cpp_quote("#endif")
+};
+ comlib/SafeArrayPrim.c view
@@ -0,0 +1,10 @@+
+#include "autoPrim.h"
+#include "SafeArrayPrim.h"
+
+/* Finaliser for SAFEARRAYs */
+void
+primSafeArrayDestroy(void* p)
+{
+  SafeArrayDestroy((SAFEARRAY*)p);
+}
+ comlib/StdDispatch.lhs view
@@ -0,0 +1,501 @@+%
+% (c), Sigbjorn Finne, 1999-
+%
+
+Implementation of IDispatch in Haskell; pretty useful
+when creating/registering dynamic, on-the-fly event
+sinks.
+
+ToDo: have HaskellDirect generate code which targets
+this implementation, and (maybe) make this impl. the
+default instead of the typelib-driven one.
+
+\begin{code}
+module StdDispatch
+	( createStdDispatchVTBL
+        , createStdDispatchVTBL2
+	
+	, createStdDispatch
+
+        , DispMethod(..)
+
+	, inArg
+	, inIUnknownArg
+	, inoutArg
+	, outArg
+	, retVal
+
+	, apply_0
+	, apply_1
+	, apply_2
+	, apply_3
+	, apply_4
+	, apply_5
+	, apply_6
+	, apply_7
+
+	, mkDispMethod
+	, dispmethod_0_0
+	, dispmethod_1_0
+	, dispmethod_2_0
+	, dispmethod_3_0
+
+	, dispmethod_0_1
+	, dispmethod_0_2
+
+	) where
+
+import TypeLib hiding (DISPID,invoke, getIDsOfNames)
+import ComServ
+import Com
+import Automation
+import HDirect
+import Foreign.Ptr
+import Foreign.Storable
+import ComException
+import WideString
+import Bits
+import IOExts
+import Int
+import List ( find )
+
+\end{code}
+
+\begin{code}
+createStdDispatch :: objState
+		  -> IO ()
+                  -> [DispMethod objState]
+		  -> IID (IUnknown iid)
+		  -> IO (IUnknown iid)
+createStdDispatch objState final meths iid = do
+  vtbl <- createStdDispatchVTBL2 meths
+  createComInstance "" objState final
+                       [ mkIface iid vtbl
+		       , mkIface iidIDispatch vtbl
+		       ]
+		       iid
+\end{code}
+
+
+This presents a simple, no-fuss implementation of a custom
+IDispatch interface. It takes care of the minutiae of
+implementing IDispatch, but leaves the programmer with the
+task of specifying the instance specific bits of: mapping
+from method names to DISPIDs + the invocation function which
+performs the action associated with a particular DISPID,
+including the marshaling and unmarshaling of VARIANT args.
+
+Abstractions with varying degress of sophistication can be
+layered on top of this basic IDispatch impl - see 
+<tt/createStdDispatchVTBL2/ for one way of doing this.
+
+\begin{code}
+createStdDispatchVTBL :: (String -> Maybe DISPID)
+                      -> (DISPID -> MethodKind -> [VARIANT] -> objState -> IO (Maybe VARIANT))
+	              -> IO (ComVTable (IDispatch iid) objState)
+createStdDispatchVTBL meths fun = do
+  a_getTypeInfoCount <- export_getTypeInfoCount getTypeInfoCount_none
+  a_getTypeInfo	     <- export_getTypeInfo      getTypeInfo_none
+  a_getIDsOfNames    <- export_getIDsOfNames	(getIDsOfNames meths)
+  a_invoke	     <- export_invoke		(invoke fun)
+  createComVTable 
+           [ a_getTypeInfoCount
+	   , a_getTypeInfo
+	   , a_getIDsOfNames
+	   , a_invoke
+	   ]
+\end{code}
+
+evDisp = 
+{-
+  simpleDisp mapDISPIDs
+             invokeDISPIDs
+-}
+  simpleDisp2 
+     [ dispmethod_0_0 "DownloadComplete" 1 onDownloadComplete
+     , dispmethod_0_0 "DownloadBegin"    2 onDownloadBegin
+     ]
+ where
+  mapDISPIDs x =
+    case x of
+	  "DownloadComplete" -> Just 1
+	  "DownloadBegin"    -> Just 2
+	  "ProgressChange"   -> Just 3
+	  _                  -> Nothing
+
+  invokeDISPIDs st d mk args =
+    case d of
+	  1 -> st # onDownloadComplete
+	  2 -> st # onDownloadBegin
+	  3 -> st # onProgressChange
+	  _ -> return Nothing -- silently ignore.
+	  
+\begin{code}
+data DispMethod objState
+  = DispMethod {
+       disp_method_name :: String,     -- method name
+       disp_method_id   :: DISPID,     -- its ...
+       disp_method_kind :: MethodKind, -- bit of a misnomer.
+       disp_method_act  :: ([VARIANT] -> objState -> IO (Maybe VARIANT))
+    }
+
+mkDispMethod :: String
+             -> DISPID
+	     -> ([VARIANT] -> objState -> IO (Maybe VARIANT))
+	     -> DispMethod objState
+mkDispMethod nm d f = DispMethod nm d Method f
+
+dispmethod_0_0 :: String -> DISPID -> (objState -> IO ()) -> DispMethod objState
+dispmethod_0_0 name id f 
+  = DispMethod name id Method (apply_0 f)
+dispmethod_1_0 name id f 
+  = DispMethod name id Method (inArg $ \ x -> apply_0 (f x))
+dispmethod_2_0 name id f 
+  = DispMethod name id Method 
+               (inArg $ \ x -> inArg $ \ y -> apply_0 (f x y))
+dispmethod_3_0 name id f 
+  = DispMethod name id Method 
+               (inArg $ \ x -> inArg $ \ y -> inArg $ \ z -> apply_0 (f x y z))
+
+dispmethod_0_1 name id f 
+  = DispMethod name id Method
+               (outArg $ \ ret_x -> apply_1 f ret_x)
+
+dispmethod_0_2 name id f 
+  = DispMethod name id Method
+               (outArg $ \ ret_x -> outArg $ \ ret_y -> apply_2 f ret_x ret_y)
+
+-- and so on..
+
+createStdDispatchVTBL2 :: [DispMethod objState]
+                       -> IO (ComVTable (IDispatch iid) objState)
+createStdDispatchVTBL2 assoc = createStdDispatchVTBL lookup_dispid invoke_meths
+ where
+  lookup_dispid m_nm = 
+    case (find ((==m_nm).disp_method_name) assoc) of
+	  Nothing      -> Nothing
+	  Just d       -> Just (disp_method_id d)
+
+  invoke_meths did mkind args obj_st = 
+     case (find ((==did).disp_method_id) assoc) of
+	   Nothing      -> return Nothing
+	   Just d       -> (disp_method_act d) args obj_st
+
+\end{code}
+
+When using <tt/createStdDispatchVTBL2/, here's a couple
+of helper functions to let you wrap up 
+
+  HRESULT f([in]int i,[in,out]int* j,[out]int* pres, [out,retval]int* retval);
+
+ wrap_f = 
+  inArg     $ \ i       ->
+  inArg     $ \ j j_out ->
+  resArg    $ \ pres    ->
+  retVal    $ \ retval  ->
+  apply_3 (f i j) j_out pres retval
+
+\begin{code}
+inArg :: ( Variant a )
+      => (a -> [VARIANT] -> objState -> IO b)
+      -> [VARIANT]
+      -> objState
+      -> IO b
+inArg cont (a:args) objState = do
+   x <- resVariant a
+   cont x args objState
+
+inIUnknownArg :: (IUnknown a -> [VARIANT] -> objState -> IO b)
+              -> [VARIANT]
+              -> objState
+              -> IO b
+inIUnknownArg cont (a:args) objState = do
+   x <- resIUnknown a
+   cont x args objState
+
+inoutArg :: ( Variant a, Variant b )
+         => ( a -> (b -> IO ()) -> [VARIANT] -> objState -> IO c)
+         -> [VARIANT]
+         -> objState
+         -> IO c
+inoutArg cont (a:args) objState = do
+   x <- resVariant a
+   cont x (\ x -> inVariant x a) args objState
+
+outArg    :: ( Variant a )
+	  => ((a -> IO ()) -> [VARIANT] -> objState -> IO b)
+          -> [VARIANT]
+	  -> objState
+	  -> IO b
+outArg cont (a:args) objState = cont (\ x -> inVariant x a) args objState
+
+retVal  :: ( Variant a )
+        => ((a -> IO ()) -> [VARIANT] -> objState -> IO (Maybe VARIANT))
+	-> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+retVal cont args objState = do
+   -- what a hack.
+  res_ref <- newIORef Nothing
+  cont (\ x -> writeIORef res_ref (Just x)) args objState 
+  retv <- readIORef res_ref
+  case retv of
+    Nothing -> return Nothing
+    Just x  -> do
+      pVarResult <- allocBytes (fromIntegral sizeofVARIANT)
+      inVariant x pVarResult
+      return (Just pVarResult)
+
+apply_0 :: (objState -> IO ())
+        -> [VARIANT]
+        -> objState
+        -> IO (Maybe VARIANT)
+apply_0 f _ objState = f objState >> return Nothing
+
+apply_1 :: (Variant a)
+        => (objState -> IO a)
+	-> (a -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_1 f res_1 _ objState = do
+   x <- f objState
+   res_1 x
+   return Nothing
+
+apply_2 :: (Variant a0, Variant a1)
+        => (objState -> IO (a0,a1))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_2 f res_1 res_2 _ objState = do
+   (x,y) <- f objState
+   res_1 x
+   res_2 y
+   return Nothing
+
+apply_3 :: (Variant a0, Variant a1, Variant a2)
+        => (objState -> IO (a0,a1,a2))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+	-> (a2 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_3 f res_1 res_2 res_3 _ objState = do
+   (a0,a1,a2) <- f objState
+   res_1 a0
+   res_2 a1
+   res_3 a2
+   return Nothing
+
+apply_4 :: (Variant a0, Variant a1, Variant a2, Variant a3)
+        => (objState -> IO (a0,a1,a2,a3))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+	-> (a2 -> IO ())
+	-> (a3 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_4 f res_1 res_2 res_3 res_4 _ objState = do
+   (a0,a1,a2,a3) <- f objState
+   res_1 a0
+   res_2 a1
+   res_3 a2
+   res_4 a3
+   return Nothing
+
+apply_5 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4)
+        => (objState -> IO (a0,a1,a2,a3,a4))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+	-> (a2 -> IO ())
+	-> (a3 -> IO ())
+	-> (a4 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_5 f res_1 res_2 res_3 res_4 res_5 _ objState = do
+   (a0,a1,a2,a3,a4) <- f objState
+   res_1 a0
+   res_2 a1
+   res_3 a2
+   res_4 a3
+   res_5 a4
+   return Nothing
+
+apply_6 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4, Variant a5)
+        => (objState -> IO (a0,a1,a2,a3,a4,a5))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+	-> (a2 -> IO ())
+	-> (a3 -> IO ())
+	-> (a4 -> IO ())
+	-> (a5 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_6 f res_1 res_2 res_3 res_4 res_5 res_6 _ objState = do
+   (a0,a1,a2,a3,a4,a5) <- f objState
+   res_1 a0
+   res_2 a1
+   res_3 a2
+   res_4 a3
+   res_5 a4
+   res_6 a5
+   return Nothing
+
+apply_7 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4, Variant a5, Variant a6)
+        => (objState -> IO (a0,a1,a2,a3,a4,a5,a6))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+	-> (a2 -> IO ())
+	-> (a3 -> IO ())
+	-> (a4 -> IO ())
+	-> (a5 -> IO ())
+	-> (a6 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_7 f res_1 res_2 res_3 res_4 res_5 res_6 res_7 _ objState = do
+   (a0,a1,a2,a3,a4,a5,a6) <- f objState
+   res_1 a0
+   res_2 a1
+   res_3 a2
+   res_4 a3
+   res_5 a4
+   res_6 a5
+   res_7 a6
+   return Nothing
+
+\end{code}
+
+
+\begin{code}
+type ThisPtr a = Ptr a
+
+invoke :: (DISPID -> MethodKind -> [VARIANT] -> objState -> IO (Maybe VARIANT))
+       -> Ptr (IDispatch ())
+       -> DISPID
+       -> Ptr (IID ())
+       -> LCID
+       -> Word32
+       -> Ptr (Ptr ()) --DISPPARAMS
+       -> Ptr VARIANT
+       -> Ptr (Ptr ()) --EXCEPINFO
+       -> Ptr Word32
+       -> IO HRESULT
+invoke dispMeth this dispIdMember riid lcid wFlags pDispParams
+       pVarResult pExcepInfo puArgErr = do
+   iid <- unmarshallIID False riid
+   if (iid /= iidNULL) then
+      return dISP_E_UNKNOWNINTERFACE
+    else do
+      let mkind = toMethodKind wFlags
+          args  = unsafePerformIO (unmarshallArgs (castPtr pDispParams))
+      st  <- getObjState this
+      catch (do
+        res <- dispMeth dispIdMember mkind args st
+        case res of 
+          Nothing -> do
+	    if pVarResult == nullPtr then
+	       return ()
+	     else
+ 	       poke pVarResult nullPtr
+          Just x  -> do
+--           putMessage ("Invoke: " ++ show dispIdMember ++ " interested")
+	    writeVARIANT pVarResult x
+        return s_OK) 
+       (\ err -> 
+          case coGetErrorHR err of
+	    Nothing -> do
+	      if pExcepInfo == nullPtr then
+	         return dISP_E_EXCEPTION
+	       else do
+	         poke (castPtr pExcepInfo) nullPtr
+		 return dISP_E_EXCEPTION
+	    Just hr ->
+	      -- ToDo: a lot better.
+	      if pExcepInfo == nullPtr then
+	         return hr
+	       else do
+	         poke (castPtr pExcepInfo) nullPtr
+		 return hr)
+	      
+
+unmarshallArgs :: Ptr DISPPARAMS -> IO [VARIANT]
+unmarshallArgs ptr 
+  | ptr == nullPtr = return []
+  | otherwise       = do
+     dp <- readDISPPARAMS (castPtr ptr)
+     case dp of
+       (TagDISPPARAMS rs _) -> return rs
+
+
+data MethodKind = Method | PropertyGet | PropertyPut
+
+toMethodKind :: Word32 -> MethodKind
+toMethodKind x
+  | x .&. dISPATCH_METHOD         /= 0 = Method
+  | x .&. dISPATCH_PROPERTYGET    /= 0 = PropertyGet
+  | x .&. dISPATCH_PROPERTYPUT    /= 0 = PropertyPut
+  | x .&. dISPATCH_PROPERTYPUTREF /= 0 = PropertyPut
+  | otherwise			       = Method
+
+dISPATCH_METHOD :: Word32
+dISPATCH_METHOD = 0x1
+dISPATCH_PROPERTYGET :: Word32
+dISPATCH_PROPERTYGET = 0x2
+dISPATCH_PROPERTYPUT :: Word32
+dISPATCH_PROPERTYPUT = 0x4
+dISPATCH_PROPERTYPUTREF :: Word32
+dISPATCH_PROPERTYPUTREF = 0x8
+
+\end{code}
+
+\begin{code}
+getIDsOfNames :: (String -> Maybe DISPID)
+	      -> ThisPtr (IDispatch ())
+	      -> Ptr (IID ())
+	      -> Ptr WideString
+	      -> Word32
+	      -> LCID
+	      -> Ptr DISPID
+	      -> IO HRESULT
+getIDsOfNames lookup_dispid this riid rgszNames cNames lcid rgDispID
+  | cNames /= 1 = return e_FAIL
+  | otherwise   = do
+      pwide     <- peek (castPtr rgszNames)
+      (pstr,hr) <- wideToString pwide
+      checkHR hr
+      str       <- unmarshallString (castPtr pstr)
+      case lookup_dispid str of
+        Nothing -> return e_FAIL
+	Just v  -> do
+	   writeInt32 rgDispID v
+	   return s_OK
+
+\end{code}
+
+We don't expose type information of any sort, so 
+here's the negative versions of the two IDispatch
+methods.
+
+\begin{code}
+getTypeInfoCount_none :: Ptr () -> Ptr Word32 -> IO HRESULT
+getTypeInfoCount_none iptr pctInfo = do
+  writeWord32 pctInfo 0
+  return s_OK
+
+getTypeInfo_none :: Ptr (IDispatch ()) -> Word32 -> LCID -> Ptr () -> IO HRESULT
+getTypeInfo_none this iTInfo lcid ppTInfo
+  | iTInfo /= 0         = return tYPE_E_ELEMENTNOTFOUND
+  | ppTInfo == nullPtr = return e_POINTER
+  | otherwise		= do
+     poke (castPtr ppTInfo) nullPtr
+     return s_OK
+
+\end{code}
+ comlib/StdTypes.h view
@@ -0,0 +1,129 @@+/*
+Automatically generated by HaskellDirect (ihc.exe), version 0.20
+Created: 20:11 Pacific Standard Time, Tuesday 16 December, 2003
+Command line: -fno-qualified-names -fno-export-list -fno-gen-variant-instances -fout-pointers-are-not-refs --gen-headers -c StdTypes.idl -o StdTypes.hs
+*/
+
+
+#ifndef __INT64_DEFINED__
+#ifdef __GNUC__
+typedef long long int64;
+typedef unsigned long long uint64;
+#else
+#ifdef _MSC_VER
+typedef __int64 int64;
+typedef unsigned __int64 uint64;
+#else
+/* Need some help here, please. */
+#endif
+#endif
+#define __INT64_DEFINED__
+#endif
+
+
+#ifndef __STDTYPES_H__
+#define __STDTYPES_H__
+#ifdef __MINGW32__
+#define __need_wchar_t
+#include <stddef.h>
+#endif
+typedef unsigned long UINT;
+typedef int INT;
+typedef long BOOL;
+typedef char BYTE;
+typedef long LONG;
+typedef unsigned long ULONG;
+typedef unsigned short WORD;
+typedef unsigned long DWORD;
+typedef unsigned short VARTYPE;
+typedef unsigned short USHORT;
+typedef DWORD LCID;
+typedef LONG SCODE;
+typedef short SHORT;
+typedef wchar_t WCHAR;
+typedef WCHAR TCHAR;
+typedef WCHAR OLECHAR;
+typedef /*[string]*/ WCHAR* LPOLESTR;
+typedef /*[string]*/ WCHAR* LPCOLESTR;
+typedef void* PVOID;
+typedef void* LPVOID;
+typedef float FLOAT;
+/*typedef [ignore] [ignore]struct _GUID {
+                      [ignore]unsigned long Data1;
+                      [ignore]unsigned short Data2;
+                      [ignore]unsigned short Data3;
+                      char [ignore] Data4[8];
+                   } GUID;*/
+typedef struct _GUID {
+DWORD Data1;
+WORD  Data2;
+WORD  Data3;
+BYTE  Data4[8];
+} GUID;
+/*typedef [ignore] GUID IID;*/
+typedef GUID IID;
+typedef IID* LPIID;
+/*typedef [ignore] GUID CLSID;*/
+typedef GUID CLSID;
+typedef CLSID* LPCLSID;
+typedef GUID FMTID;
+typedef FMTID* LPFMTID;
+typedef /*[ptr]*/ void* HWND;
+typedef /*[ptr]*/ void* HMENU;
+typedef /*[ptr]*/ void* HANDLE;
+typedef /*[ref]*/ GUID* REFGUID;
+typedef /*[ref]*/ IID* REFIID;
+typedef /*[ref]*/ CLSID* REFCLSID;
+typedef /*[ref]*/ FMTID* REFFMTID;
+typedef enum VARENUM {
+           VT_EMPTY = 0,
+           VT_NULL = 1,
+           VT_I2 = 2,
+           VT_I4 = 3,
+           VT_R4 = 4,
+           VT_R8 = 5,
+           VT_CY = 6,
+           VT_DATE = 7,
+           VT_BSTR = 8,
+           VT_DISPATCH = 9,
+           VT_ERROR = 10,
+           VT_BOOL = 11,
+           VT_VARIANT = 12,
+           VT_UNKNOWN = 13,
+           VT_DECIMAL = 14,
+           VT_I1 = 16,
+           VT_UI1 = 17,
+           VT_UI2 = 18,
+           VT_UI4 = 19,
+           VT_I8 = 20,
+           VT_UI8 = 21,
+           VT_INT = 22,
+           VT_UINT = 23,
+           VT_VOID = 24,
+           VT_HRESULT = 25,
+           VT_PTR = 26,
+           VT_SAFEARRAY = 27,
+           VT_CARRAY = 28,
+           VT_USERDEFINED = 29,
+           VT_LPSTR = 30,
+           VT_LPWSTR = 31,
+           VT_FILETIME = 64,
+           VT_BLOB = 65,
+           VT_STREAM = 66,
+           VT_STORAGE = 67,
+           VT_STREAMED_OBJECT = 68,
+           VT_STORED_OBJECT = 69,
+           VT_BLOB_OBJECT = 70,
+           VT_CF = 71,
+           VT_CLSID = 72,
+           VT_BSTR_BLOB = 4095,
+           VT_ILLEGALMASKED = 4095,
+           VT_TYPEMASK = 4095,
+           VT_VECTOR = 4096,
+           VT_ARRAY = 8192,
+           VT_BYREF = 16384,
+           VT_RESERVED = 32768,
+           VT_ILLEGAL = 65535
+        } VARENUM;
+
+#endif
+ comlib/StdTypes.hs view
@@ -0,0 +1,237 @@+-- Automatically generated by HaskellDirect (ihc.exe), version 0.20
+-- Created: 20:11 Pacific Standard Time, Tuesday 16 December, 2003
+-- Command line: -fno-qualified-names -fno-export-list -fno-gen-variant-instances -fout-pointers-are-not-refs --gen-headers -c StdTypes.idl -o StdTypes.hs
+
+module StdTypes where
+
+import Prelude
+import Com (IID, CLSID, GUID)
+import Foreign.Ptr (Ptr)
+import HDirect (Wchar_t)
+import Int (Int32, Int16)
+import WideString (WideString)
+import Word (Word32, Word16)
+
+{- BEGIN_C_CODE
+#ifdef __MINGW32__
+END_C_CODE-}
+{- BEGIN_C_CODE
+#define __need_wchar_t
+END_C_CODE-}
+{- BEGIN_C_CODE
+#include <stddef.h>
+END_C_CODE-}
+{- BEGIN_C_CODE
+#endif
+END_C_CODE-}
+type UINT = Word32
+type INT = Int32
+type BOOL = Int32
+type BYTE = Char
+type LONG = Int32
+type ULONG = Word32
+type WORD = Word16
+type DWORD = Word32
+type VARTYPE = Word16
+type USHORT = Word16
+type LCID = DWORD
+type SCODE = LONG
+type SHORT = Int16
+type WCHAR = Wchar_t
+type TCHAR = WCHAR
+type OLECHAR = WCHAR
+type LPOLESTR = WideString
+type LPCOLESTR = WideString
+type PVOID = Ptr ()
+type LPVOID = Ptr ()
+type FLOAT = Float
+{- BEGIN_C_CODE
+typedef struct _GUID {
+END_C_CODE-}
+{- BEGIN_C_CODE
+DWORD Data1;
+END_C_CODE-}
+{- BEGIN_C_CODE
+WORD  Data2;
+END_C_CODE-}
+{- BEGIN_C_CODE
+WORD  Data3;
+END_C_CODE-}
+{- BEGIN_C_CODE
+BYTE  Data4[8];
+END_C_CODE-}
+{- BEGIN_C_CODE
+} GUID;
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef GUID IID;
+END_C_CODE-}
+type LPIID = IID ()
+{- BEGIN_C_CODE
+typedef GUID CLSID;
+END_C_CODE-}
+type LPCLSID = CLSID
+type FMTID = GUID
+type LPFMTID = GUID
+type HWND = Ptr ()
+type HMENU = Ptr ()
+type HANDLE = Ptr ()
+type REFGUID = GUID
+type REFIID = IID ()
+type REFCLSID = CLSID
+type REFFMTID = GUID
+data VARENUM
+ = VT_EMPTY
+ | VT_NULL
+ | VT_I2
+ | VT_I4
+ | VT_R4
+ | VT_R8
+ | VT_CY
+ | VT_DATE
+ | VT_BSTR
+ | VT_DISPATCH
+ | VT_ERROR
+ | VT_BOOL
+ | VT_VARIANT
+ | VT_UNKNOWN
+ | VT_DECIMAL
+ | VT_I1
+ | VT_UI1
+ | VT_UI2
+ | VT_UI4
+ | VT_I8
+ | VT_UI8
+ | VT_INT
+ | VT_UINT
+ | VT_VOID
+ | VT_HRESULT
+ | VT_PTR
+ | VT_SAFEARRAY
+ | VT_CARRAY
+ | VT_USERDEFINED
+ | VT_LPSTR
+ | VT_LPWSTR
+ | VT_FILETIME
+ | VT_BLOB
+ | VT_STREAM
+ | VT_STORAGE
+ | VT_STREAMED_OBJECT
+ | VT_STORED_OBJECT
+ | VT_BLOB_OBJECT
+ | VT_CF
+ | VT_CLSID
+ | VT_BSTR_BLOB
+ | VT_ILLEGALMASKED
+ | VT_TYPEMASK
+ | VT_VECTOR
+ | VT_ARRAY
+ | VT_BYREF
+ | VT_RESERVED
+ | VT_ILLEGAL
+ 
+instance Enum (VARENUM) where
+  fromEnum v =
+    case v of
+       VT_EMPTY -> 0
+       VT_NULL -> 1
+       VT_I2 -> 2
+       VT_I4 -> 3
+       VT_R4 -> 4
+       VT_R8 -> 5
+       VT_CY -> 6
+       VT_DATE -> 7
+       VT_BSTR -> 8
+       VT_DISPATCH -> 9
+       VT_ERROR -> 10
+       VT_BOOL -> 11
+       VT_VARIANT -> 12
+       VT_UNKNOWN -> 13
+       VT_DECIMAL -> 14
+       VT_I1 -> 16
+       VT_UI1 -> 17
+       VT_UI2 -> 18
+       VT_UI4 -> 19
+       VT_I8 -> 20
+       VT_UI8 -> 21
+       VT_INT -> 22
+       VT_UINT -> 23
+       VT_VOID -> 24
+       VT_HRESULT -> 25
+       VT_PTR -> 26
+       VT_SAFEARRAY -> 27
+       VT_CARRAY -> 28
+       VT_USERDEFINED -> 29
+       VT_LPSTR -> 30
+       VT_LPWSTR -> 31
+       VT_FILETIME -> 64
+       VT_BLOB -> 65
+       VT_STREAM -> 66
+       VT_STORAGE -> 67
+       VT_STREAMED_OBJECT -> 68
+       VT_STORED_OBJECT -> 69
+       VT_BLOB_OBJECT -> 70
+       VT_CF -> 71
+       VT_CLSID -> 72
+       VT_BSTR_BLOB -> 4095
+       VT_ILLEGALMASKED -> 4095
+       VT_TYPEMASK -> 4095
+       VT_VECTOR -> 4096
+       VT_ARRAY -> 8192
+       VT_BYREF -> 16384
+       VT_RESERVED -> 32768
+       VT_ILLEGAL -> 65535
+  
+  toEnum v =
+    case v of
+       0 -> VT_EMPTY
+       1 -> VT_NULL
+       2 -> VT_I2
+       3 -> VT_I4
+       4 -> VT_R4
+       5 -> VT_R8
+       6 -> VT_CY
+       7 -> VT_DATE
+       8 -> VT_BSTR
+       9 -> VT_DISPATCH
+       10 -> VT_ERROR
+       11 -> VT_BOOL
+       12 -> VT_VARIANT
+       13 -> VT_UNKNOWN
+       14 -> VT_DECIMAL
+       16 -> VT_I1
+       17 -> VT_UI1
+       18 -> VT_UI2
+       19 -> VT_UI4
+       20 -> VT_I8
+       21 -> VT_UI8
+       22 -> VT_INT
+       23 -> VT_UINT
+       24 -> VT_VOID
+       25 -> VT_HRESULT
+       26 -> VT_PTR
+       27 -> VT_SAFEARRAY
+       28 -> VT_CARRAY
+       29 -> VT_USERDEFINED
+       30 -> VT_LPSTR
+       31 -> VT_LPWSTR
+       64 -> VT_FILETIME
+       65 -> VT_BLOB
+       66 -> VT_STREAM
+       67 -> VT_STORAGE
+       68 -> VT_STREAMED_OBJECT
+       69 -> VT_STORED_OBJECT
+       70 -> VT_BLOB_OBJECT
+       71 -> VT_CF
+       72 -> VT_CLSID
+       4095 -> VT_BSTR_BLOB
+       4095 -> VT_ILLEGALMASKED
+       4095 -> VT_TYPEMASK
+       4096 -> VT_VECTOR
+       8192 -> VT_ARRAY
+       16384 -> VT_BYREF
+       32768 -> VT_RESERVED
+       65535 -> VT_ILLEGAL
+       _ -> error "unmarshallVARENUM: illegal enum value "
+  
+
+ comlib/StdTypes.idl view
@@ -0,0 +1,127 @@+//
+// Some common 
+module StdTypes {
+
+cpp_quote("#ifdef __MINGW32__")
+cpp_quote("#define __need_wchar_t")
+cpp_quote("#include <stddef.h>")
+cpp_quote("#endif")
+
+typedef unsigned int UINT;
+typedef int INT;
+typedef long BOOL;
+typedef unsigned char BYTE;
+typedef long LONG;
+typedef unsigned long ULONG;
+typedef unsigned short WORD;
+typedef unsigned long DWORD;
+typedef unsigned short VARTYPE;
+typedef unsigned short USHORT;
+
+typedef DWORD LCID;
+typedef LONG SCODE;
+typedef short           SHORT;
+
+typedef wchar_t WCHAR;
+typedef WCHAR   TCHAR;
+typedef WCHAR                   OLECHAR;
+typedef [string] OLECHAR       *LPOLESTR;
+typedef [string] const OLECHAR *LPCOLESTR;
+
+typedef void * PVOID, * LPVOID;
+typedef float   FLOAT;
+
+// 
+// Annotate GUID, IID and CLSID with [ignore] - don't want
+// to generate stubs/types for them. (they're provided by Com.)
+// 
+typedef [ignore]struct _GUID
+{
+    DWORD Data1;
+    WORD  Data2;
+    WORD  Data3;
+    BYTE  Data4[8];
+} GUID;
+cpp_quote("typedef struct _GUID {")
+cpp_quote("DWORD Data1;")
+cpp_quote("WORD  Data2;")
+cpp_quote("WORD  Data3;")
+cpp_quote("BYTE  Data4[8];")
+cpp_quote("} GUID;")
+
+typedef [ignore]GUID IID;
+cpp_quote("typedef GUID IID;")
+typedef IID *LPIID;
+typedef [ignore]GUID CLSID;
+cpp_quote("typedef GUID CLSID;")
+typedef              CLSID *LPCLSID;
+typedef GUID FMTID;
+typedef              FMTID *LPFMTID;
+
+typedef [ptr]void*   HWND;
+typedef [ptr]void*   HMENU;
+typedef [ptr]void*   HANDLE;
+
+typedef [ref]GUID *REFGUID;
+typedef [ref]IID *REFIID;
+typedef [ref]CLSID *REFCLSID;
+typedef [ref]FMTID *REFFMTID;
+
+enum VARENUM
+{
+    VT_EMPTY           = 0,
+    VT_NULL            = 1,
+    VT_I2              = 2,
+    VT_I4              = 3,
+    VT_R4              = 4,
+    VT_R8              = 5,
+    VT_CY              = 6,
+    VT_DATE            = 7,
+    VT_BSTR            = 8,
+    VT_DISPATCH        = 9,
+    VT_ERROR           = 10,
+    VT_BOOL            = 11,
+    VT_VARIANT         = 12,
+    VT_UNKNOWN         = 13,
+    VT_DECIMAL         = 14,
+
+    VT_I1              = 16,
+    VT_UI1             = 17,
+    VT_UI2             = 18,
+    VT_UI4             = 19,
+    VT_I8              = 20,
+    VT_UI8             = 21,
+    VT_INT             = 22,
+    VT_UINT            = 23,
+    VT_VOID            = 24,
+    VT_HRESULT         = 25,
+    VT_PTR             = 26,
+    VT_SAFEARRAY       = 27,
+    VT_CARRAY          = 28,
+    VT_USERDEFINED     = 29,
+    VT_LPSTR           = 30,
+    VT_LPWSTR          = 31,
+
+    VT_FILETIME        = 64,
+    VT_BLOB            = 65,
+    VT_STREAM          = 66,
+    VT_STORAGE         = 67,
+    VT_STREAMED_OBJECT = 68,
+    VT_STORED_OBJECT   = 69,
+    VT_BLOB_OBJECT     = 70,
+    VT_CF              = 71,
+    VT_CLSID           = 72,
+
+    VT_BSTR_BLOB       = 0x0fff,
+
+    VT_VECTOR          = 0x1000,
+    VT_ARRAY           = 0x2000,
+    VT_BYREF           = 0x4000,
+    VT_RESERVED        = 0x8000,
+
+    VT_ILLEGAL         = 0xffff,
+    VT_ILLEGALMASKED   = 0x0fff,
+    VT_TYPEMASK        = 0x0fff
+};
+
+}
+ comlib/TypeLib.hs view
@@ -0,0 +1,2863 @@+-- Automatically generated by HaskellDirect (ihc.exe), version 0.20
+-- Created: 20:13 Pacific Standard Time, Tuesday 16 December, 2003
+-- Command line: -fno-qualified-names -fno-export-list -fappend-interface-short-name -fno-overload-variant --gen-headers -c TypeLib.idl -o TypeLib.hs
+
+module TypeLib where
+
+import Prelude
+import Automation (VARIANT, copyVARIANT, unmarshallVARIANT, 
+                   writeVARIANT, sizeofVARIANT, readVARIANT, marshallVARIANT, 
+                   allocVARIANT)
+import Bits ((.&.))
+import Com (GUID, writeGUID, readGUID, freeBSTR, writeBSTR, 
+            readBSTR, IUnknown, writeIUnknown, readIUnknown, IID, mkIID, 
+            marshallGUID, invokeAndCheck, marshallIUnknown, marshallBSTR, 
+            marshallIID, invokeIt)
+import Foreign.ForeignPtr (withForeignPtr)
+import Foreign.Ptr (Ptr, castPtr)
+import HDirect (writeWord32, writeInt32, addNCastPtr, readWord32, 
+                readInt32, marshallUnion, unmarshallUnion, allocBytes, 
+                writeunique, readunique, writeWord16, readWord16, free, writelist, 
+                unmarshallWord16, unmarshalllist, trivialFree, writeEnum32, 
+                readEnum32, derefPtr, marshalllist, sizeofInt32, writePtr, 
+                readPtr, unmarshallWord32, Flags(..), pow2Series, orList, 
+                writeInt16, readInt16, unmarshallInt16, writeMaybe, readMaybe, 
+                sizeofWord32, doThenFree, marshallref, sizeofPtr, marshallEnum32, 
+                sizeofForeignPtr, freeref, sizeofWord16)
+import Int (Int32, Int16)
+import Maybe (mapMaybe)
+import StdTypes (LONG, ULONG, DWORD, VARTYPE, USHORT, WORD, 
+                 LPOLESTR, LCID, SCODE, SHORT, PVOID, REFGUID, UINT, INT, BOOL)
+import WideString (writeWideString, readWideString, 
+                   marshallWideString, freeWideString, WideString, 
+                   unmarshallWideString)
+import Word (Word32, Word16)
+
+{- BEGIN_C_CODE
+#include "StdTypes.h"
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef void* VARIANT;
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef void* BSTR;
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef DWORD HRESULT;
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef void* IUnknown;
+END_C_CODE-}
+data SAFEARRAYBOUND = TagSAFEARRAYBOUND {cElements :: ULONG,
+                                         lLbound :: LONG}
+                        
+writeSAFEARRAYBOUND :: Ptr SAFEARRAYBOUND
+                    -> SAFEARRAYBOUND
+                    -> IO ()
+writeSAFEARRAYBOUND ptr (TagSAFEARRAYBOUND cElements lLbound) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 cElements
+    let pf2 = addNCastPtr pf1 4
+    writeInt32 pf2 lLbound
+
+readSAFEARRAYBOUND :: Ptr SAFEARRAYBOUND
+                   -> IO SAFEARRAYBOUND
+readSAFEARRAYBOUND ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    cElements <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    lLbound <- readInt32 pf2
+    return (TagSAFEARRAYBOUND cElements lLbound)
+
+sizeofSAFEARRAYBOUND :: Word32
+sizeofSAFEARRAYBOUND = 8
+
+type LPSAFEARRAYBOUND = SAFEARRAYBOUND
+type DISPID = LONG
+type MEMBERID = DISPID
+type HREFTYPE = DWORD
+data TYPEKIND
+ = TKIND_ENUM
+ | TKIND_RECORD
+ | TKIND_MODULE
+ | TKIND_INTERFACE
+ | TKIND_DISPATCH
+ | TKIND_COCLASS
+ | TKIND_ALIAS
+ | TKIND_UNION
+ | TKIND_MAX
+ deriving (Enum)
+type IHC_TAG_4 = TYPEDESC
+type IHC_TAG_5 = ARRAYDESC
+data IHC_TAG_3
+ = Lptdesc (Maybe IHC_TAG_4)
+ | Lpadesc (Maybe IHC_TAG_5)
+ | Hreftype HREFTYPE
+ | IHC_TAG_3_Anon
+ 
+marshallIHC_TAG_3 :: IHC_TAG_3
+                  -> IO (IHC_TAG_3, Word16)
+marshallIHC_TAG_3 = marshallUnion "marshallIHC_TAG_3"
+
+unmarshallIHC_TAG_3 :: IHC_TAG_3
+                    -> Word16
+                    -> IO IHC_TAG_3
+unmarshallIHC_TAG_3 = unmarshallUnion "unmarshallIHC_TAG_3"
+
+writeIHC_TAG_3 :: (Word16 -> IO ())
+               -> Ptr IHC_TAG_3
+               -> IHC_TAG_3
+               -> IO ()
+writeIHC_TAG_3 write_tag ptr v =
+  case v of
+     (Lptdesc lptdesc) -> do
+                            write_tag 26
+                            writeunique (allocBytes (fromIntegral sizeofTYPEDESC)) writeTYPEDESC (castPtr ptr) lptdesc
+     (Lpadesc lpadesc) -> do
+                            write_tag 28
+                            writeunique (allocBytes (fromIntegral sizeofARRAYDESC)) writeARRAYDESC (castPtr ptr) lpadesc
+     (Hreftype hreftype) -> do
+                              write_tag 29
+                              writeWord32 (castPtr ptr) hreftype
+     IHC_TAG_3_Anon -> return ()
+
+readIHC_TAG_3 :: IO Word16
+              -> Ptr IHC_TAG_3
+              -> IO IHC_TAG_3
+readIHC_TAG_3 read_tag ptr =
+  do
+    tag <- read_tag
+    case tag of
+       26 -> do
+               v <- readunique readTYPEDESC (castPtr ptr)
+               return (Lptdesc v)
+       27 -> do
+               v <- readunique readTYPEDESC (castPtr ptr)
+               return (Lptdesc v)
+       28 -> do
+               v <- readunique readARRAYDESC (castPtr ptr)
+               return (Lpadesc v)
+       29 -> do
+               v <- readWord32 (castPtr ptr)
+               return (Hreftype v)
+       _ -> return (IHC_TAG_3_Anon)
+
+sizeofIHC_TAG_3 :: Word32
+sizeofIHC_TAG_3 = 4
+
+freeIHC_TAG_3 :: Word16
+              -> Ptr IHC_TAG_3
+              -> IO ()
+freeIHC_TAG_3 read_tag ptr =
+  do
+    tag <- return (read_tag)
+    case tag of
+       26 -> return ()
+       27 -> return ()
+       28 -> return ()
+       29 -> return ()
+       _ -> return ()
+
+type IHC_TAG_2 = IHC_TAG_3
+data TYPEDESC = TagTYPEDESC {iHC_TAG_1 :: IHC_TAG_3,
+                             vt :: VARTYPE}
+                  
+writeTYPEDESC :: Ptr TYPEDESC
+              -> TYPEDESC
+              -> IO ()
+writeTYPEDESC ptr (TagTYPEDESC iHC_TAG_1 vt) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeIHC_TAG_3 (writeWord16 (addNCastPtr pf0 4)) pf1 iHC_TAG_1
+    let pf2 = addNCastPtr pf1 4
+    writeWord16 pf2 vt
+
+readTYPEDESC :: Ptr TYPEDESC
+             -> IO TYPEDESC
+readTYPEDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    iHC_TAG_1 <- readIHC_TAG_3 (readWord16 (addNCastPtr pf0 4)) pf1
+    let pf2 = addNCastPtr pf1 4
+    vt <- readWord16 pf2
+    return (TagTYPEDESC iHC_TAG_1 vt)
+
+sizeofTYPEDESC :: Word32
+sizeofTYPEDESC = 8
+
+data ARRAYDESC = TagARRAYDESC {tdescElem :: TYPEDESC,
+                               rgbounds :: [SAFEARRAYBOUND]}
+                   
+freeARRAYDESC :: Ptr ARRAYDESC
+              -> IO ()
+freeARRAYDESC ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 12
+  in
+  free struct_ptr__
+
+writeARRAYDESC :: Ptr ARRAYDESC
+               -> ARRAYDESC
+               -> IO ()
+writeARRAYDESC ptr (TagARRAYDESC tdescElem rgbounds) =
+  let
+   cDims = (fromIntegral (length rgbounds) :: Word16)
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeTYPEDESC pf1 tdescElem
+    let pf2 = addNCastPtr pf1 8
+    writeWord16 pf2 cDims
+    let pf3 = addNCastPtr pf2 4
+    writelist False sizeofSAFEARRAYBOUND writeSAFEARRAYBOUND pf3 rgbounds
+
+readARRAYDESC :: Ptr ARRAYDESC
+              -> IO ARRAYDESC
+readARRAYDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    tdescElem <- readTYPEDESC pf1
+    let pf2 = addNCastPtr pf1 8
+    cDims <- readWord16 pf2
+    let pf3 = addNCastPtr pf2 4
+    rgbounds <- return pf3
+    cDims <- unmarshallWord16 cDims
+    rgbounds <- unmarshalllist sizeofSAFEARRAYBOUND 0 ((fromIntegral cDims :: Word32)) readSAFEARRAYBOUND rgbounds
+    return (TagARRAYDESC tdescElem rgbounds)
+
+sizeofARRAYDESC :: Word32
+sizeofARRAYDESC = 20
+
+type VARIANTARG = VARIANT
+data PARAMDESCEX = TagPARAMDESCEX {cBytes :: ULONG,
+                                   varDefaultValue :: VARIANT}
+                     
+freePARAMDESCEX :: Ptr PARAMDESCEX
+                -> IO ()
+freePARAMDESCEX ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 8
+  in
+  trivialFree struct_ptr__
+
+writePARAMDESCEX :: Ptr PARAMDESCEX
+                 -> PARAMDESCEX
+                 -> IO ()
+writePARAMDESCEX ptr (TagPARAMDESCEX cBytes varDefaultValue) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 cBytes
+    let pf2 = addNCastPtr pf1 8
+    copyVARIANT pf2 varDefaultValue
+
+readPARAMDESCEX :: Ptr PARAMDESCEX
+                -> IO PARAMDESCEX
+readPARAMDESCEX ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    cBytes <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 8
+    varDefaultValue <- unmarshallVARIANT pf2
+    return (TagPARAMDESCEX cBytes varDefaultValue)
+
+sizeofPARAMDESCEX :: Word32
+sizeofPARAMDESCEX = 24
+
+type LPPARAMDESCEX = Maybe PARAMDESCEX
+data PARAMDESC = TagPARAMDESC {pparamdescex :: LPPARAMDESCEX,
+                               wParamFlags :: USHORT}
+                   
+freePARAMDESC :: Ptr PARAMDESC
+              -> IO ()
+freePARAMDESC ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 0
+  in
+  trivialFree struct_ptr__
+
+writePARAMDESC :: Ptr PARAMDESC
+               -> PARAMDESC
+               -> IO ()
+writePARAMDESC ptr (TagPARAMDESC pparamdescex wParamFlags) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeunique (allocBytes (fromIntegral sizeofPARAMDESCEX)) writePARAMDESCEX pf1 pparamdescex
+    let pf2 = addNCastPtr pf1 4
+    writeWord16 pf2 wParamFlags
+
+readPARAMDESC :: Ptr PARAMDESC
+              -> IO PARAMDESC
+readPARAMDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    pparamdescex <- readunique readPARAMDESCEX pf1
+    let pf2 = addNCastPtr pf1 4
+    wParamFlags <- readWord16 pf2
+    return (TagPARAMDESC pparamdescex wParamFlags)
+
+sizeofPARAMDESC :: Word32
+sizeofPARAMDESC = 8
+
+type LPPARAMDESC = PARAMDESC
+pARAMFLAG_NONE :: USHORT
+pARAMFLAG_NONE = 0x0
+
+pARAMFLAG_FIN :: USHORT
+pARAMFLAG_FIN = 0x1
+
+pARAMFLAG_FOUT :: USHORT
+pARAMFLAG_FOUT = 0x2
+
+pARAMFLAG_FLCID :: USHORT
+pARAMFLAG_FLCID = 0x4
+
+pARAMFLAG_FRETVAL :: USHORT
+pARAMFLAG_FRETVAL = 0x8
+
+pARAMFLAG_FOPT :: USHORT
+pARAMFLAG_FOPT = 0x10
+
+pARAMFLAG_FHASDEFAULT :: USHORT
+pARAMFLAG_FHASDEFAULT = 0x20
+
+data IDLDESC = TagIDLDESC {dwReserved :: ULONG,
+                           wIDLFlags :: USHORT}
+                 
+writeIDLDESC :: Ptr IDLDESC
+             -> IDLDESC
+             -> IO ()
+writeIDLDESC ptr (TagIDLDESC dwReserved wIDLFlags) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 dwReserved
+    let pf2 = addNCastPtr pf1 4
+    writeWord16 pf2 wIDLFlags
+
+readIDLDESC :: Ptr IDLDESC
+            -> IO IDLDESC
+readIDLDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    dwReserved <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    wIDLFlags <- readWord16 pf2
+    return (TagIDLDESC dwReserved wIDLFlags)
+
+sizeofIDLDESC :: Word32
+sizeofIDLDESC = 8
+
+type LPIDLDESC = IDLDESC
+iDLFLAG_NONE :: USHORT
+iDLFLAG_NONE = 0
+
+iDLFLAG_FIN :: USHORT
+iDLFLAG_FIN = 1
+
+iDLFLAG_FOUT :: USHORT
+iDLFLAG_FOUT = 2
+
+iDLFLAG_FLCID :: USHORT
+iDLFLAG_FLCID = 4
+
+iDLFLAG_FRETVAL :: USHORT
+iDLFLAG_FRETVAL = 8
+
+{- BEGIN_C_CODE
+#if 0
+END_C_CODE-}
+{- BEGIN_C_CODE
+/* the following is what MIDL knows how to remote */
+END_C_CODE-}
+data ELEMDESC = TagELEMDESC {tdesc :: TYPEDESC,
+                             paramdesc :: PARAMDESC}
+                  
+freeELEMDESC :: Ptr ELEMDESC
+             -> IO ()
+freeELEMDESC ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 8
+  in
+  freePARAMDESC struct_ptr__
+
+writeELEMDESC :: Ptr ELEMDESC
+              -> ELEMDESC
+              -> IO ()
+writeELEMDESC ptr (TagELEMDESC tdesc paramdesc) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeTYPEDESC pf1 tdesc
+    let pf2 = addNCastPtr pf1 8
+    writePARAMDESC pf2 paramdesc
+
+readELEMDESC :: Ptr ELEMDESC
+             -> IO ELEMDESC
+readELEMDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    tdesc <- readTYPEDESC pf1
+    let pf2 = addNCastPtr pf1 8
+    paramdesc <- readPARAMDESC pf2
+    return (TagELEMDESC tdesc paramdesc)
+
+sizeofELEMDESC :: Word32
+sizeofELEMDESC = 16
+
+{- BEGIN_C_CODE
+#else /* 0 */
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef struct tagELEMDESC {
+END_C_CODE-}
+{- BEGIN_C_CODE
+    TYPEDESC tdesc;             /* the type of the element */
+END_C_CODE-}
+{- BEGIN_C_CODE
+    union {
+END_C_CODE-}
+{- BEGIN_C_CODE
+        IDLDESC idldesc;        /* info for remoting the element */
+END_C_CODE-}
+{- BEGIN_C_CODE
+        PARAMDESC paramdesc;    /* info about the parameter */
+END_C_CODE-}
+{- BEGIN_C_CODE
+    };
+END_C_CODE-}
+{- BEGIN_C_CODE
+} ELEMDESC, * LPELEMDESC;
+END_C_CODE-}
+{- BEGIN_C_CODE
+#endif /* 0 */
+END_C_CODE-}
+data TYPEATTR = TagTYPEATTR {guid :: GUID,
+                             lcid :: LCID,
+                             dwReserved0 :: DWORD,
+                             memidConstructor :: MEMBERID,
+                             memidDestructor :: MEMBERID,
+                             lpstrSchema :: LPOLESTR,
+                             cbSizeInstance :: ULONG,
+                             typekind :: TYPEKIND,
+                             cFuncs :: WORD,
+                             cVars :: WORD,
+                             cImplTypes :: WORD,
+                             cbSizeVft :: WORD,
+                             cbAlignment :: WORD,
+                             wTypeFlags :: WORD,
+                             wMajorVerNum :: WORD,
+                             wMinorVerNum :: WORD,
+                             tdescAlias :: TYPEDESC,
+                             idldescType :: IDLDESC}
+                  
+writeTYPEATTR :: Ptr TYPEATTR
+              -> TYPEATTR
+              -> IO ()
+writeTYPEATTR ptr (TagTYPEATTR guid lcid dwReserved0 memidConstructor memidDestructor lpstrSchema cbSizeInstance typekind cFuncs cVars cImplTypes cbSizeVft cbAlignment wTypeFlags wMajorVerNum wMinorVerNum tdescAlias idldescType) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeGUID pf1 guid
+    let pf2 = addNCastPtr pf1 16
+    writeWord32 pf2 lcid
+    let pf3 = addNCastPtr pf2 4
+    writeWord32 pf3 dwReserved0
+    let pf4 = addNCastPtr pf3 4
+    writeInt32 pf4 memidConstructor
+    let pf5 = addNCastPtr pf4 4
+    writeInt32 pf5 memidDestructor
+    let pf6 = addNCastPtr pf5 4
+    writeWideString pf6 lpstrSchema
+    let pf7 = addNCastPtr pf6 4
+    writeWord32 pf7 cbSizeInstance
+    let pf8 = addNCastPtr pf7 4
+    writeEnum32 pf8 typekind
+    let pf9 = addNCastPtr pf8 4
+    writeWord16 pf9 cFuncs
+    let pf10 = addNCastPtr pf9 2
+    writeWord16 pf10 cVars
+    let pf11 = addNCastPtr pf10 2
+    writeWord16 pf11 cImplTypes
+    let pf12 = addNCastPtr pf11 2
+    writeWord16 pf12 cbSizeVft
+    let pf13 = addNCastPtr pf12 2
+    writeWord16 pf13 cbAlignment
+    let pf14 = addNCastPtr pf13 2
+    writeWord16 pf14 wTypeFlags
+    let pf15 = addNCastPtr pf14 2
+    writeWord16 pf15 wMajorVerNum
+    let pf16 = addNCastPtr pf15 2
+    writeWord16 pf16 wMinorVerNum
+    let pf17 = addNCastPtr pf16 2
+    writeTYPEDESC pf17 tdescAlias
+    let pf18 = addNCastPtr pf17 8
+    writeIDLDESC pf18 idldescType
+
+readTYPEATTR :: Bool
+             -> Ptr TYPEATTR
+             -> IO TYPEATTR
+readTYPEATTR finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    guid <- readGUID finaliseMe__ pf1
+    let pf2 = addNCastPtr pf1 16
+    lcid <- readWord32 pf2
+    let pf3 = addNCastPtr pf2 4
+    dwReserved0 <- readWord32 pf3
+    let pf4 = addNCastPtr pf3 4
+    memidConstructor <- readInt32 pf4
+    let pf5 = addNCastPtr pf4 4
+    memidDestructor <- readInt32 pf5
+    let pf6 = addNCastPtr pf5 4
+    lpstrSchema <- readWideString pf6
+    let pf7 = addNCastPtr pf6 4
+    cbSizeInstance <- readWord32 pf7
+    let pf8 = addNCastPtr pf7 4
+    typekind <- readEnum32 pf8
+    let pf9 = addNCastPtr pf8 4
+    cFuncs <- readWord16 pf9
+    let pf10 = addNCastPtr pf9 2
+    cVars <- readWord16 pf10
+    let pf11 = addNCastPtr pf10 2
+    cImplTypes <- readWord16 pf11
+    let pf12 = addNCastPtr pf11 2
+    cbSizeVft <- readWord16 pf12
+    let pf13 = addNCastPtr pf12 2
+    cbAlignment <- readWord16 pf13
+    let pf14 = addNCastPtr pf13 2
+    wTypeFlags <- readWord16 pf14
+    let pf15 = addNCastPtr pf14 2
+    wMajorVerNum <- readWord16 pf15
+    let pf16 = addNCastPtr pf15 2
+    wMinorVerNum <- readWord16 pf16
+    let pf17 = addNCastPtr pf16 2
+    tdescAlias <- readTYPEDESC pf17
+    let pf18 = addNCastPtr pf17 8
+    idldescType <- readIDLDESC pf18
+    return (TagTYPEATTR guid lcid dwReserved0 memidConstructor memidDestructor lpstrSchema cbSizeInstance typekind cFuncs cVars cImplTypes cbSizeVft cbAlignment wTypeFlags wMajorVerNum wMinorVerNum tdescAlias idldescType)
+
+sizeofTYPEATTR :: Word32
+sizeofTYPEATTR = 76
+
+type LPTYPEATTR = TYPEATTR
+data DISPPARAMS = TagDISPPARAMS {rgvarg :: [VARIANT],
+                                 rgdispidNamedArgs :: [Int32]}
+                    
+freeDISPPARAMS :: Ptr DISPPARAMS
+               -> IO ()
+freeDISPPARAMS ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 0
+  in
+  do
+    field_ptr__ <- derefPtr struct_ptr__
+    free field_ptr__
+
+writeDISPPARAMS :: Ptr DISPPARAMS
+                -> DISPPARAMS
+                -> IO ()
+writeDISPPARAMS ptr (TagDISPPARAMS rgvarg rgdispidNamedArgs) =
+  let
+   cArgs = (fromIntegral (length rgvarg) :: Word32)
+  in
+  do
+    rgvarg <- marshalllist sizeofVARIANT writeVARIANT rgvarg
+    let cNamedArgs = (fromIntegral (length rgdispidNamedArgs) :: Word32)
+    rgdispidNamedArgs <- marshalllist sizeofInt32 writeInt32 rgdispidNamedArgs
+    let pf0 = ptr
+        pf1 = addNCastPtr pf0 0
+    writePtr pf1 rgvarg
+    let pf2 = addNCastPtr pf1 4
+    writePtr pf2 rgdispidNamedArgs
+    let pf3 = addNCastPtr pf2 4
+    writeWord32 pf3 cArgs
+    let pf4 = addNCastPtr pf3 4
+    writeWord32 pf4 cNamedArgs
+
+readDISPPARAMS :: Ptr DISPPARAMS
+               -> IO DISPPARAMS
+readDISPPARAMS ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    rgvarg <- readPtr pf1
+    let pf2 = addNCastPtr pf1 4
+    rgdispidNamedArgs <- readPtr pf2
+    let pf3 = addNCastPtr pf2 4
+    cArgs <- readWord32 pf3
+    let pf4 = addNCastPtr pf3 4
+    cNamedArgs <- readWord32 pf4
+    cArgs <- unmarshallWord32 cArgs
+    cNamedArgs <- unmarshallWord32 cNamedArgs
+    rgvarg <- unmarshalllist sizeofVARIANT 0 ((fromIntegral cArgs :: Word32)) readVARIANT rgvarg
+    rgdispidNamedArgs <- unmarshalllist sizeofInt32 0 ((fromIntegral cNamedArgs :: Word32)) readInt32 rgdispidNamedArgs
+    return (TagDISPPARAMS rgvarg rgdispidNamedArgs)
+
+sizeofDISPPARAMS :: Word32
+sizeofDISPPARAMS = 16
+
+{- BEGIN_C_CODE
+#if 0
+END_C_CODE-}
+{- BEGIN_C_CODE
+/* the following is what MIDL knows how to remote */
+END_C_CODE-}
+data EXCEPINFO = TagEXCEPINFO {wCode :: WORD,
+                               wReserved :: WORD,
+                               bstrSource :: String,
+                               bstrDescription :: String,
+                               bstrHelpFile :: String,
+                               dwHelpContext :: DWORD,
+                               pvReserved :: ULONG,
+                               pfnDeferredFillIn :: ULONG,
+                               scode :: SCODE}
+                   
+freeEXCEPINFO :: Ptr EXCEPINFO
+              -> IO ()
+freeEXCEPINFO ptr =
+  do
+    let struct_ptr__ = addNCastPtr ptr 4
+    freeBSTR struct_ptr__
+    let struct_ptr__ = addNCastPtr ptr 8
+    freeBSTR struct_ptr__
+    let struct_ptr__ = addNCastPtr ptr 12
+    freeBSTR struct_ptr__
+
+writeEXCEPINFO :: Ptr EXCEPINFO
+               -> EXCEPINFO
+               -> IO ()
+writeEXCEPINFO ptr (TagEXCEPINFO wCode wReserved bstrSource bstrDescription bstrHelpFile dwHelpContext pvReserved pfnDeferredFillIn scode) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord16 pf1 wCode
+    let pf2 = addNCastPtr pf1 2
+    writeWord16 pf2 wReserved
+    let pf3 = addNCastPtr pf2 2
+    writeBSTR pf3 bstrSource
+    let pf4 = addNCastPtr pf3 4
+    writeBSTR pf4 bstrDescription
+    let pf5 = addNCastPtr pf4 4
+    writeBSTR pf5 bstrHelpFile
+    let pf6 = addNCastPtr pf5 4
+    writeWord32 pf6 dwHelpContext
+    let pf7 = addNCastPtr pf6 4
+    writeWord32 pf7 pvReserved
+    let pf8 = addNCastPtr pf7 4
+    writeWord32 pf8 pfnDeferredFillIn
+    let pf9 = addNCastPtr pf8 4
+    writeInt32 pf9 scode
+
+readEXCEPINFO :: Ptr EXCEPINFO
+              -> IO EXCEPINFO
+readEXCEPINFO ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    wCode <- readWord16 pf1
+    let pf2 = addNCastPtr pf1 2
+    wReserved <- readWord16 pf2
+    let pf3 = addNCastPtr pf2 2
+    bstrSource <- readBSTR pf3
+    let pf4 = addNCastPtr pf3 4
+    bstrDescription <- readBSTR pf4
+    let pf5 = addNCastPtr pf4 4
+    bstrHelpFile <- readBSTR pf5
+    let pf6 = addNCastPtr pf5 4
+    dwHelpContext <- readWord32 pf6
+    let pf7 = addNCastPtr pf6 4
+    pvReserved <- readWord32 pf7
+    let pf8 = addNCastPtr pf7 4
+    pfnDeferredFillIn <- readWord32 pf8
+    let pf9 = addNCastPtr pf8 4
+    scode <- readInt32 pf9
+    return (TagEXCEPINFO wCode wReserved bstrSource bstrDescription bstrHelpFile dwHelpContext pvReserved pfnDeferredFillIn scode)
+
+sizeofEXCEPINFO :: Word32
+sizeofEXCEPINFO = 32
+
+{- BEGIN_C_CODE
+#else /* 0 */
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef struct tagEXCEPINFO {
+END_C_CODE-}
+{- BEGIN_C_CODE
+    WORD  wCode;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    WORD  wReserved;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    BSTR  bstrSource;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    BSTR  bstrDescription;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    BSTR  bstrHelpFile;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    DWORD dwHelpContext;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    PVOID pvReserved;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    HRESULT (__stdcall *pfnDeferredFillIn)(struct tagEXCEPINFO *);
+END_C_CODE-}
+{- BEGIN_C_CODE
+    SCODE scode;
+END_C_CODE-}
+{- BEGIN_C_CODE
+} EXCEPINFO, * LPEXCEPINFO;
+END_C_CODE-}
+{- BEGIN_C_CODE
+#endif /* 0 */
+END_C_CODE-}
+data CALLCONV
+ = CC_FASTCALL
+ | CC_CDECL
+ | CC_MSCPASCAL
+ | CC_PASCAL
+ | CC_MACPASCAL
+ | CC_STDCALL
+ | CC_FPFASTCALL
+ | CC_SYSCALL
+ | CC_MPWCDECL
+ | CC_MPWPASCAL
+ | CC_MAX
+ 
+instance Enum (CALLCONV) where
+  fromEnum v =
+    case v of
+       CC_FASTCALL -> 0
+       CC_CDECL -> 1
+       CC_MSCPASCAL -> 2
+       CC_PASCAL -> 2
+       CC_MACPASCAL -> 3
+       CC_STDCALL -> 4
+       CC_FPFASTCALL -> 5
+       CC_SYSCALL -> 6
+       CC_MPWCDECL -> 7
+       CC_MPWPASCAL -> 8
+       CC_MAX -> 9
+  
+  toEnum v =
+    case v of
+       0 -> CC_FASTCALL
+       1 -> CC_CDECL
+       2 -> CC_MSCPASCAL
+       2 -> CC_PASCAL
+       3 -> CC_MACPASCAL
+       4 -> CC_STDCALL
+       5 -> CC_FPFASTCALL
+       6 -> CC_SYSCALL
+       7 -> CC_MPWCDECL
+       8 -> CC_MPWPASCAL
+       9 -> CC_MAX
+       _ -> error "unmarshallCALLCONV: illegal enum value "
+  
+data FUNCKIND
+ = FUNC_VIRTUAL
+ | FUNC_PUREVIRTUAL
+ | FUNC_NONVIRTUAL
+ | FUNC_STATIC
+ | FUNC_DISPATCH
+ deriving (Enum)
+data INVOKEKIND
+ = INVOKEKINDList__ [INVOKEKIND]
+ | INVOKE_FUNC
+ | INVOKE_PROPERTYGET
+ | INVOKE_PROPERTYPUT
+ | INVOKE_PROPERTYPUTREF
+ 
+instance Flags (INVOKEKIND) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (INVOKEKIND) where
+  fromEnum v =
+    case v of
+       (INVOKEKINDList__ xs) -> orList (map fromEnum xs)
+       INVOKE_FUNC -> 1
+       INVOKE_PROPERTYGET -> 2
+       INVOKE_PROPERTYPUT -> 4
+       INVOKE_PROPERTYPUTREF -> 8
+  
+  toEnum v =
+    case v of
+       1 -> INVOKE_FUNC
+       2 -> INVOKE_PROPERTYGET
+       4 -> INVOKE_PROPERTYPUT
+       8 -> INVOKE_PROPERTYPUTREF
+       x -> INVOKEKINDList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                   then Just (toEnum (fromIntegral val))
+                                                   else Nothing) (pow2Series 4 1))
+       _ -> error "unmarshallINVOKEKIND: illegal enum value "
+  
+data VARKIND
+ = VAR_PERINSTANCE
+ | VAR_STATIC
+ | VAR_CONST
+ | VAR_DISPATCH
+ deriving (Enum)
+data FUNCDESC = TagFUNCDESC {memid :: MEMBERID,
+                             lprgscode :: [Int32],
+                             lprgelemdescParam :: [ELEMDESC],
+                             funckind :: FUNCKIND,
+                             invkind :: INVOKEKIND,
+                             callconv :: CALLCONV,
+                             cParamsOpt :: SHORT,
+                             oVft :: SHORT,
+                             elemdescFunc :: ELEMDESC,
+                             wFuncFlags :: WORD}
+                  
+freeFUNCDESC :: Ptr FUNCDESC
+             -> IO ()
+freeFUNCDESC ptr =
+  do
+    let struct_ptr__ = addNCastPtr ptr 8
+    field_ptr__ <- derefPtr struct_ptr__
+    free field_ptr__
+    let struct_ptr__ = addNCastPtr ptr 32
+    trivialFree struct_ptr__
+
+writeFUNCDESC :: Ptr FUNCDESC
+              -> FUNCDESC
+              -> IO ()
+writeFUNCDESC ptr (TagFUNCDESC memid lprgscode lprgelemdescParam funckind invkind callconv cParamsOpt oVft elemdescFunc wFuncFlags) =
+  let
+   cScodes = (fromIntegral (length lprgscode) :: Int16)
+  in
+  do
+    lprgscode <- marshalllist sizeofInt32 writeInt32 lprgscode
+    let cParams = (fromIntegral (length lprgelemdescParam) :: Int16)
+    lprgelemdescParam <- marshalllist sizeofELEMDESC writeELEMDESC lprgelemdescParam
+    let pf0 = ptr
+        pf1 = addNCastPtr pf0 0
+    writeInt32 pf1 memid
+    let pf2 = addNCastPtr pf1 4
+    writePtr pf2 lprgscode
+    let pf3 = addNCastPtr pf2 4
+    writePtr pf3 lprgelemdescParam
+    let pf4 = addNCastPtr pf3 4
+    writeEnum32 pf4 funckind
+    let pf5 = addNCastPtr pf4 4
+    writeEnum32 pf5 invkind
+    let pf6 = addNCastPtr pf5 4
+    writeEnum32 pf6 callconv
+    let pf7 = addNCastPtr pf6 4
+    writeInt16 pf7 cParams
+    let pf8 = addNCastPtr pf7 2
+    writeInt16 pf8 cParamsOpt
+    let pf9 = addNCastPtr pf8 2
+    writeInt16 pf9 oVft
+    let pf10 = addNCastPtr pf9 2
+    writeInt16 pf10 cScodes
+    let pf11 = addNCastPtr pf10 2
+    writeELEMDESC pf11 elemdescFunc
+    let pf12 = addNCastPtr pf11 16
+    writeWord16 pf12 wFuncFlags
+
+readFUNCDESC :: Ptr FUNCDESC
+             -> IO FUNCDESC
+readFUNCDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    memid <- readInt32 pf1
+    let pf2 = addNCastPtr pf1 4
+    lprgscode <- readPtr pf2
+    let pf3 = addNCastPtr pf2 4
+    lprgelemdescParam <- readPtr pf3
+    let pf4 = addNCastPtr pf3 4
+    funckind <- readEnum32 pf4
+    let pf5 = addNCastPtr pf4 4
+    invkind <- readEnum32 pf5
+    let pf6 = addNCastPtr pf5 4
+    callconv <- readEnum32 pf6
+    let pf7 = addNCastPtr pf6 4
+    cParams <- readInt16 pf7
+    let pf8 = addNCastPtr pf7 2
+    cParamsOpt <- readInt16 pf8
+    let pf9 = addNCastPtr pf8 2
+    oVft <- readInt16 pf9
+    let pf10 = addNCastPtr pf9 2
+    cScodes <- readInt16 pf10
+    let pf11 = addNCastPtr pf10 2
+    elemdescFunc <- readELEMDESC pf11
+    let pf12 = addNCastPtr pf11 16
+    wFuncFlags <- readWord16 pf12
+    cScodes <- unmarshallInt16 cScodes
+    cParams <- unmarshallInt16 cParams
+    lprgscode <- unmarshalllist sizeofInt32 0 ((fromIntegral cScodes :: Word32)) readInt32 lprgscode
+    lprgelemdescParam <- unmarshalllist sizeofELEMDESC 0 ((fromIntegral cParams :: Word32)) readELEMDESC lprgelemdescParam
+    return (TagFUNCDESC memid lprgscode lprgelemdescParam funckind invkind callconv cParamsOpt oVft elemdescFunc wFuncFlags)
+
+sizeofFUNCDESC :: Word32
+sizeofFUNCDESC = 52
+
+type LPFUNCDESC = FUNCDESC
+iMPLTYPEFLAG_FDEFAULT :: USHORT
+iMPLTYPEFLAG_FDEFAULT = 0x1
+
+iMPLTYPEFLAG_FSOURCE :: USHORT
+iMPLTYPEFLAG_FSOURCE = 0x2
+
+iMPLTYPEFLAG_FRESTRICTED :: USHORT
+iMPLTYPEFLAG_FRESTRICTED = 0x4
+
+iMPLTYPEFLAG_FDEFAULTVTABLE :: USHORT
+iMPLTYPEFLAG_FDEFAULTVTABLE = 0x8
+
+data IHC_TAG_9
+ = OInst ULONG
+ | LpvarValue (Maybe VARIANT)
+ 
+marshallIHC_TAG_9 :: IHC_TAG_9
+                  -> IO (IHC_TAG_9, Int32)
+marshallIHC_TAG_9 = marshallUnion "marshallIHC_TAG_9"
+
+unmarshallIHC_TAG_9 :: IHC_TAG_9
+                    -> Int32
+                    -> IO IHC_TAG_9
+unmarshallIHC_TAG_9 = unmarshallUnion "unmarshallIHC_TAG_9"
+
+writeIHC_TAG_9 :: (Int32 -> IO ())
+               -> Ptr IHC_TAG_9
+               -> IHC_TAG_9
+               -> IO ()
+writeIHC_TAG_9 write_tag ptr v =
+  case v of
+     (OInst oInst) -> do
+                        write_tag 0
+                        writeWord32 (castPtr ptr) oInst
+     (LpvarValue lpvarValue) -> do
+                                  write_tag 2
+                                  writeMaybe writeVARIANT (castPtr ptr) lpvarValue
+
+readIHC_TAG_9 :: IO Int32
+              -> Ptr IHC_TAG_9
+              -> IO IHC_TAG_9
+readIHC_TAG_9 read_tag ptr =
+  do
+    tag <- read_tag
+    case tag of
+       0 -> do
+              v <- readWord32 (castPtr ptr)
+              return (OInst v)
+       3 -> do
+              v <- readWord32 (castPtr ptr)
+              return (OInst v)
+       1 -> do
+              v <- readWord32 (castPtr ptr)
+              return (OInst v)
+       2 -> do
+              v <- readMaybe readVARIANT (castPtr ptr)
+              return (LpvarValue v)
+
+sizeofIHC_TAG_9 :: Word32
+sizeofIHC_TAG_9 = 4
+
+freeIHC_TAG_9 :: Int32
+              -> Ptr IHC_TAG_9
+              -> IO ()
+freeIHC_TAG_9 read_tag ptr =
+  do
+    tag <- return (read_tag)
+    case tag of
+       0 -> return ()
+       3 -> return ()
+       1 -> return ()
+       2 -> free (castPtr ptr)
+
+type IHC_TAG_8 = IHC_TAG_9
+data VARDESC = TagVARDESC {memid0 :: MEMBERID,
+                           lpstrSchema0 :: LPOLESTR,
+                           iHC_TAG_7 :: IHC_TAG_9,
+                           elemdescVar :: ELEMDESC,
+                           wVarFlags :: WORD,
+                           varkind :: VARKIND}
+                 
+freeVARDESC :: Ptr VARDESC
+            -> IO ()
+freeVARDESC ptr =
+  do
+    varkind <- readInt32 (addNCastPtr ptr 32)
+    return ()
+    let struct_ptr__ = addNCastPtr ptr 4
+    trivialFree struct_ptr__
+    let struct_ptr__ = addNCastPtr ptr 8
+    trivialFree struct_ptr__
+    let struct_ptr__ = addNCastPtr ptr 12
+    trivialFree struct_ptr__
+
+writeVARDESC :: Ptr VARDESC
+             -> VARDESC
+             -> IO ()
+writeVARDESC ptr (TagVARDESC memid0 lpstrSchema0 iHC_TAG_7 elemdescVar wVarFlags varkind) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeInt32 pf1 memid0
+    let pf2 = addNCastPtr pf1 4
+    writeWideString pf2 lpstrSchema0
+    let pf3 = addNCastPtr pf2 4
+    writeIHC_TAG_9 (writeInt32 (addNCastPtr pf0 32)) pf3 iHC_TAG_7
+    let pf4 = addNCastPtr pf3 4
+    writeELEMDESC pf4 elemdescVar
+    let pf5 = addNCastPtr pf4 16
+    writeWord16 pf5 wVarFlags
+    let pf6 = addNCastPtr pf5 4
+    writeEnum32 pf6 varkind
+
+readVARDESC :: Ptr VARDESC
+            -> IO VARDESC
+readVARDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    memid0 <- readInt32 pf1
+    let pf2 = addNCastPtr pf1 4
+    lpstrSchema0 <- readWideString pf2
+    let pf3 = addNCastPtr pf2 4
+    iHC_TAG_7 <- readIHC_TAG_9 (readInt32 (addNCastPtr pf0 32)) pf3
+    let pf4 = addNCastPtr pf3 4
+    elemdescVar <- readELEMDESC pf4
+    let pf5 = addNCastPtr pf4 16
+    wVarFlags <- readWord16 pf5
+    let pf6 = addNCastPtr pf5 4
+    varkind <- readEnum32 pf6
+    return (TagVARDESC memid0 lpstrSchema0 iHC_TAG_7 elemdescVar wVarFlags varkind)
+
+sizeofVARDESC :: Word32
+sizeofVARDESC = 36
+
+type LPVARDESC = VARDESC
+data TYPEFLAGS
+ = TYPEFLAGSList__ [TYPEFLAGS]
+ | TYPEFLAG_FAPPOBJECT
+ | TYPEFLAG_FCANCREATE
+ | TYPEFLAG_FLICENSED
+ | TYPEFLAG_FPREDECLID
+ | TYPEFLAG_FHIDDEN
+ | TYPEFLAG_FCONTROL
+ | TYPEFLAG_FDUAL
+ | TYPEFLAG_FNONEXTENSIBLE
+ | TYPEFLAG_FOLEAUTOMATION
+ | TYPEFLAG_FRESTRICTED
+ | TYPEFLAG_FAGGREGATABLE
+ | TYPEFLAG_FREPLACEABLE
+ | TYPEFLAG_FDISPATCHABLE
+ | TYPEFLAG_FREVERSEBIND
+ 
+instance Flags (TYPEFLAGS) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (TYPEFLAGS) where
+  fromEnum v =
+    case v of
+       (TYPEFLAGSList__ xs) -> orList (map fromEnum xs)
+       TYPEFLAG_FAPPOBJECT -> 1
+       TYPEFLAG_FCANCREATE -> 2
+       TYPEFLAG_FLICENSED -> 4
+       TYPEFLAG_FPREDECLID -> 8
+       TYPEFLAG_FHIDDEN -> 16
+       TYPEFLAG_FCONTROL -> 32
+       TYPEFLAG_FDUAL -> 64
+       TYPEFLAG_FNONEXTENSIBLE -> 128
+       TYPEFLAG_FOLEAUTOMATION -> 256
+       TYPEFLAG_FRESTRICTED -> 512
+       TYPEFLAG_FAGGREGATABLE -> 1024
+       TYPEFLAG_FREPLACEABLE -> 2048
+       TYPEFLAG_FDISPATCHABLE -> 4096
+       TYPEFLAG_FREVERSEBIND -> 8192
+  
+  toEnum v =
+    case v of
+       1 -> TYPEFLAG_FAPPOBJECT
+       2 -> TYPEFLAG_FCANCREATE
+       4 -> TYPEFLAG_FLICENSED
+       8 -> TYPEFLAG_FPREDECLID
+       16 -> TYPEFLAG_FHIDDEN
+       32 -> TYPEFLAG_FCONTROL
+       64 -> TYPEFLAG_FDUAL
+       128 -> TYPEFLAG_FNONEXTENSIBLE
+       256 -> TYPEFLAG_FOLEAUTOMATION
+       512 -> TYPEFLAG_FRESTRICTED
+       1024 -> TYPEFLAG_FAGGREGATABLE
+       2048 -> TYPEFLAG_FREPLACEABLE
+       4096 -> TYPEFLAG_FDISPATCHABLE
+       8192 -> TYPEFLAG_FREVERSEBIND
+       x -> TYPEFLAGSList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                  then Just (toEnum (fromIntegral val))
+                                                  else Nothing) (pow2Series 14 1))
+       _ -> error "unmarshallTYPEFLAGS: illegal enum value "
+  
+data FUNCFLAGS
+ = FUNCFLAGSList__ [FUNCFLAGS]
+ | FUNCFLAG_FRESTRICTED
+ | FUNCFLAG_FSOURCE
+ | FUNCFLAG_FBINDABLE
+ | FUNCFLAG_FREQUESTEDIT
+ | FUNCFLAG_FDISPLAYBIND
+ | FUNCFLAG_FDEFAULTBIND
+ | FUNCFLAG_FHIDDEN
+ | FUNCFLAG_FUSESGETLASTERROR
+ | FUNCFLAG_FDEFAULTCOLLELEM
+ | FUNCFLAG_FUIDEFAULT
+ | FUNCFLAG_FNONBROWSABLE
+ | FUNCFLAG_FREPLACEABLE
+ | FUNCFLAG_FIMMEDIATEBIND
+ 
+instance Flags (FUNCFLAGS) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (FUNCFLAGS) where
+  fromEnum v =
+    case v of
+       (FUNCFLAGSList__ xs) -> orList (map fromEnum xs)
+       FUNCFLAG_FRESTRICTED -> 1
+       FUNCFLAG_FSOURCE -> 2
+       FUNCFLAG_FBINDABLE -> 4
+       FUNCFLAG_FREQUESTEDIT -> 8
+       FUNCFLAG_FDISPLAYBIND -> 16
+       FUNCFLAG_FDEFAULTBIND -> 32
+       FUNCFLAG_FHIDDEN -> 64
+       FUNCFLAG_FUSESGETLASTERROR -> 128
+       FUNCFLAG_FDEFAULTCOLLELEM -> 256
+       FUNCFLAG_FUIDEFAULT -> 512
+       FUNCFLAG_FNONBROWSABLE -> 1024
+       FUNCFLAG_FREPLACEABLE -> 2048
+       FUNCFLAG_FIMMEDIATEBIND -> 4096
+  
+  toEnum v =
+    case v of
+       1 -> FUNCFLAG_FRESTRICTED
+       2 -> FUNCFLAG_FSOURCE
+       4 -> FUNCFLAG_FBINDABLE
+       8 -> FUNCFLAG_FREQUESTEDIT
+       16 -> FUNCFLAG_FDISPLAYBIND
+       32 -> FUNCFLAG_FDEFAULTBIND
+       64 -> FUNCFLAG_FHIDDEN
+       128 -> FUNCFLAG_FUSESGETLASTERROR
+       256 -> FUNCFLAG_FDEFAULTCOLLELEM
+       512 -> FUNCFLAG_FUIDEFAULT
+       1024 -> FUNCFLAG_FNONBROWSABLE
+       2048 -> FUNCFLAG_FREPLACEABLE
+       4096 -> FUNCFLAG_FIMMEDIATEBIND
+       x -> FUNCFLAGSList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                  then Just (toEnum (fromIntegral val))
+                                                  else Nothing) (pow2Series 13 1))
+       _ -> error "unmarshallFUNCFLAGS: illegal enum value "
+  
+data VARFLAGS
+ = VARFLAGSList__ [VARFLAGS]
+ | VARFLAG_FREADONLY
+ | VARFLAG_FSOURCE
+ | VARFLAG_FBINDABLE
+ | VARFLAG_FREQUESTEDIT
+ | VARFLAG_FDISPLAYBIND
+ | VARFLAG_FDEFAULTBIND
+ | VARFLAG_FHIDDEN
+ | VARFLAG_FRESTRICTED
+ | VARFLAG_FDEFAULTCOLLELEM
+ | VARFLAG_FUIDEFAULT
+ | VARFLAG_FNONBROWSABLE
+ | VARFLAG_FREPLACEABLE
+ | VARFLAG_FIMMEDIATEBIND
+ 
+instance Flags (VARFLAGS) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (VARFLAGS) where
+  fromEnum v =
+    case v of
+       (VARFLAGSList__ xs) -> orList (map fromEnum xs)
+       VARFLAG_FREADONLY -> 1
+       VARFLAG_FSOURCE -> 2
+       VARFLAG_FBINDABLE -> 4
+       VARFLAG_FREQUESTEDIT -> 8
+       VARFLAG_FDISPLAYBIND -> 16
+       VARFLAG_FDEFAULTBIND -> 32
+       VARFLAG_FHIDDEN -> 64
+       VARFLAG_FRESTRICTED -> 128
+       VARFLAG_FDEFAULTCOLLELEM -> 256
+       VARFLAG_FUIDEFAULT -> 512
+       VARFLAG_FNONBROWSABLE -> 1024
+       VARFLAG_FREPLACEABLE -> 2048
+       VARFLAG_FIMMEDIATEBIND -> 4096
+  
+  toEnum v =
+    case v of
+       1 -> VARFLAG_FREADONLY
+       2 -> VARFLAG_FSOURCE
+       4 -> VARFLAG_FBINDABLE
+       8 -> VARFLAG_FREQUESTEDIT
+       16 -> VARFLAG_FDISPLAYBIND
+       32 -> VARFLAG_FDEFAULTBIND
+       64 -> VARFLAG_FHIDDEN
+       128 -> VARFLAG_FRESTRICTED
+       256 -> VARFLAG_FDEFAULTCOLLELEM
+       512 -> VARFLAG_FUIDEFAULT
+       1024 -> VARFLAG_FNONBROWSABLE
+       2048 -> VARFLAG_FREPLACEABLE
+       4096 -> VARFLAG_FIMMEDIATEBIND
+       x -> VARFLAGSList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                 then Just (toEnum (fromIntegral val))
+                                                 else Nothing) (pow2Series 13 1))
+       _ -> error "unmarshallVARFLAGS: illegal enum value "
+  
+data CLEANLOCALSTORAGE = TagCLEANLOCALSTORAGE {pInterface :: (IUnknown ()),
+                                               pStorage :: PVOID,
+                                               flags :: DWORD}
+                           
+writeCLEANLOCALSTORAGE :: Bool
+                       -> Ptr CLEANLOCALSTORAGE
+                       -> CLEANLOCALSTORAGE
+                       -> IO ()
+writeCLEANLOCALSTORAGE addRefMe__ ptr (TagCLEANLOCALSTORAGE pInterface pStorage flags) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeIUnknown addRefMe__ pf1 pInterface
+    let pf2 = addNCastPtr pf1 4
+    writePtr pf2 pStorage
+    let pf3 = addNCastPtr pf2 4
+    writeWord32 pf3 flags
+
+readCLEANLOCALSTORAGE :: Bool
+                      -> Ptr CLEANLOCALSTORAGE
+                      -> IO CLEANLOCALSTORAGE
+readCLEANLOCALSTORAGE finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    pInterface <- readIUnknown finaliseMe__ pf1
+    let pf2 = addNCastPtr pf1 4
+    pStorage <- readPtr pf2
+    let pf3 = addNCastPtr pf2 4
+    flags <- readWord32 pf3
+    return (TagCLEANLOCALSTORAGE pInterface pStorage flags)
+
+sizeofCLEANLOCALSTORAGE :: Word32
+sizeofCLEANLOCALSTORAGE = 12
+
+data CUSTDATAITEM = TagCUSTDATAITEM {guid0 :: GUID,
+                                     varValue :: VARIANT}
+                      
+freeCUSTDATAITEM :: Ptr CUSTDATAITEM
+                 -> IO ()
+freeCUSTDATAITEM ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 16
+  in
+  trivialFree struct_ptr__
+
+writeCUSTDATAITEM :: Ptr CUSTDATAITEM
+                  -> CUSTDATAITEM
+                  -> IO ()
+writeCUSTDATAITEM ptr (TagCUSTDATAITEM guid0 varValue) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeGUID pf1 guid0
+    let pf2 = addNCastPtr pf1 16
+    copyVARIANT pf2 varValue
+
+readCUSTDATAITEM :: Bool
+                 -> Ptr CUSTDATAITEM
+                 -> IO CUSTDATAITEM
+readCUSTDATAITEM finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    guid0 <- readGUID finaliseMe__ pf1
+    let pf2 = addNCastPtr pf1 16
+    varValue <- unmarshallVARIANT pf2
+    return (TagCUSTDATAITEM guid0 varValue)
+
+sizeofCUSTDATAITEM :: Word32
+sizeofCUSTDATAITEM = 32
+
+type LPCUSTDATAITEM = CUSTDATAITEM
+data CUSTDATA = TagCUSTDATA {prgCustData :: [CUSTDATAITEM]}
+                  
+freeCUSTDATA :: Ptr CUSTDATA
+             -> IO ()
+freeCUSTDATA ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 4
+  in
+  trivialFree struct_ptr__
+
+writeCUSTDATA :: Ptr CUSTDATA
+              -> CUSTDATA
+              -> IO ()
+writeCUSTDATA ptr (TagCUSTDATA prgCustData) =
+  let
+   cCustData = (fromIntegral (length prgCustData) :: Word32)
+  in
+  do
+    prgCustData <- marshalllist sizeofCUSTDATAITEM writeCUSTDATAITEM prgCustData
+    let pf0 = ptr
+        pf1 = addNCastPtr pf0 0
+    writeWord32 pf1 cCustData
+    let pf2 = addNCastPtr pf1 4
+    writePtr pf2 prgCustData
+
+readCUSTDATA :: Bool
+             -> Ptr CUSTDATA
+             -> IO CUSTDATA
+readCUSTDATA finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    cCustData <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    prgCustData <- readPtr pf2
+    cCustData <- unmarshallWord32 cCustData
+    prgCustData <- unmarshalllist sizeofCUSTDATAITEM 0 ((fromIntegral cCustData :: Word32)) (readCUSTDATAITEM finaliseMe__) prgCustData
+    return (TagCUSTDATA prgCustData)
+
+sizeofCUSTDATA :: Word32
+sizeofCUSTDATA = 8
+
+type LPCUSTDATA = CUSTDATA
+-- --------------------------------------------------
+-- 
+-- interface ICreateTypeInfo
+-- 
+-- --------------------------------------------------
+data ICreateTypeInfo_ a = ICreateTypeInfo__
+                            
+type ICreateTypeInfo a = IUnknown (ICreateTypeInfo_ a)
+iidICreateTypeInfo :: IID (ICreateTypeInfo ())
+iidICreateTypeInfo = mkIID "{00020405-0000-0000-C000-000000000046}"
+
+type LPCREATETYPEINFO = Maybe (ICreateTypeInfo ())
+setGuid :: REFGUID
+        -> ICreateTypeInfo a0
+        -> IO ()
+setGuid guid1 iptr =
+  do
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setGuid methPtr iptr guid1)) 3 iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_setGuid :: Ptr () -> Ptr () -> Ptr GUID -> IO Int32
+setTypeFlags :: UINT
+             -> ICreateTypeInfo a0
+             -> IO ()
+setTypeFlags uTypeFlags iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeFlags methPtr iptr uTypeFlags)
+                 4
+                 iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_setTypeFlags :: Ptr () -> Ptr () -> Word32 -> IO Int32
+setDocString :: LPOLESTR
+             -> ICreateTypeInfo a0
+             -> IO ()
+setDocString pStrDoc iptr =
+  do
+    pStrDoc <- marshallWideString pStrDoc
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setDocString methPtr iptr pStrDoc) 5 iptr
+    freeWideString pStrDoc
+
+foreign import stdcall "dynamic" prim_TypeLib_setDocString :: Ptr () -> Ptr () -> Ptr WideString -> IO Int32
+setHelpContext :: DWORD
+               -> ICreateTypeInfo a0
+               -> IO ()
+setHelpContext dwHelpContext0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeFlags methPtr iptr dwHelpContext0)
+                 6
+                 iptr
+
+setVersion :: WORD
+           -> WORD
+           -> ICreateTypeInfo a0
+           -> IO ()
+setVersion wMajorVerNum0 wMinorVerNum0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setVersion methPtr iptr wMajorVerNum0 wMinorVerNum0)
+                 7
+                 iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_setVersion :: Ptr () -> Ptr () -> Word16 -> Word16 -> IO Int32
+addRefTypeInfo :: ITypeInfo a1
+               -> ICreateTypeInfo a0
+               -> IO HREFTYPE
+addRefTypeInfo pTInfo iptr =
+  do
+    phRefType <- allocBytes (fromIntegral sizeofWord32)
+    pTInfo <- marshallIUnknown pTInfo
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr pTInfo (\ pTInfo -> prim_TypeLib_addRefTypeInfo methPtr iptr pTInfo phRefType)) 8 iptr
+    doThenFree free readWord32 phRefType
+
+foreign import stdcall "dynamic" prim_TypeLib_addRefTypeInfo :: Ptr () -> Ptr () -> Ptr (ITypeInfo a) -> Ptr Word32 -> IO Int32
+addFuncDesc :: UINT
+            -> FUNCDESC
+            -> ICreateTypeInfo a0
+            -> IO ()
+addFuncDesc index pFuncDesc iptr =
+  do
+    pFuncDesc <- marshallref (allocBytes (fromIntegral sizeofFUNCDESC)) writeFUNCDESC pFuncDesc
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_addFuncDesc methPtr iptr index pFuncDesc) 9 iptr
+    free pFuncDesc
+
+foreign import stdcall "dynamic" prim_TypeLib_addFuncDesc :: Ptr () -> Ptr () -> Word32 -> Ptr FUNCDESC -> IO Int32
+addImplType :: UINT
+            -> HREFTYPE
+            -> ICreateTypeInfo a0
+            -> IO ()
+addImplType index hRefType iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_addImplType methPtr iptr index hRefType)
+                 10
+                 iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_addImplType :: Ptr () -> Ptr () -> Word32 -> Word32 -> IO Int32
+setImplTypeFlags :: UINT
+                 -> INT
+                 -> ICreateTypeInfo a0
+                 -> IO ()
+setImplTypeFlags index implTypeFlags iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setImplTypeFlags methPtr iptr index implTypeFlags)
+                 11
+                 iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_setImplTypeFlags :: Ptr () -> Ptr () -> Word32 -> Int32 -> IO Int32
+setAlignment :: WORD
+             -> ICreateTypeInfo a0
+             -> IO ()
+setAlignment cbAlignment0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setAlignment methPtr iptr cbAlignment0)
+                 12
+                 iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_setAlignment :: Ptr () -> Ptr () -> Word16 -> IO Int32
+setSchema :: LPOLESTR
+          -> ICreateTypeInfo a0
+          -> IO ()
+setSchema pStrSchema iptr =
+  do
+    pStrSchema <- marshallWideString pStrSchema
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setDocString methPtr iptr pStrSchema) 13 iptr
+    freeWideString pStrSchema
+
+addVarDesc :: UINT
+           -> VARDESC
+           -> ICreateTypeInfo a0
+           -> IO ()
+addVarDesc index pVarDesc iptr =
+  do
+    pVarDesc <- marshallref (allocBytes (fromIntegral sizeofVARDESC)) writeVARDESC pVarDesc
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_addVarDesc methPtr iptr index pVarDesc) 14 iptr
+    free pVarDesc
+
+foreign import stdcall "dynamic" prim_TypeLib_addVarDesc :: Ptr () -> Ptr () -> Word32 -> Ptr VARDESC -> IO Int32
+setFuncAndParamNames :: UINT
+                     -> [LPOLESTR]
+                     -> ICreateTypeInfo a0
+                     -> IO ()
+setFuncAndParamNames index rgszNames iptr =
+  let
+   cNames = (fromIntegral (length rgszNames) :: Word32)
+  in
+  do
+    rgszNames <- marshalllist sizeofPtr writeWideString rgszNames
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setFuncAndParamNames methPtr iptr index rgszNames cNames) 15 iptr
+    free rgszNames
+
+foreign import stdcall "dynamic" prim_TypeLib_setFuncAndParamNames :: Ptr () -> Ptr () -> Word32 -> Ptr (Ptr WideString) -> Word32 -> IO Int32
+setVarName :: UINT
+           -> LPOLESTR
+           -> ICreateTypeInfo a0
+           -> IO ()
+setVarName index szName iptr =
+  do
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setVarName methPtr iptr index szName) 16 iptr
+    freeWideString szName
+
+foreign import stdcall "dynamic" prim_TypeLib_setVarName :: Ptr () -> Ptr () -> Word32 -> Ptr WideString -> IO Int32
+setTypeDescAlias :: TYPEDESC
+                 -> ICreateTypeInfo a0
+                 -> IO ()
+setTypeDescAlias pTDescAlias iptr =
+  do
+    pTDescAlias <- marshallref (allocBytes (fromIntegral sizeofTYPEDESC)) writeTYPEDESC pTDescAlias
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeDescAlias methPtr iptr pTDescAlias) 17 iptr
+    free pTDescAlias
+
+foreign import stdcall "dynamic" prim_TypeLib_setTypeDescAlias :: Ptr () -> Ptr () -> Ptr TYPEDESC -> IO Int32
+defineFuncAsDllEntry :: UINT
+                     -> LPOLESTR
+                     -> LPOLESTR
+                     -> ICreateTypeInfo a0
+                     -> IO ()
+defineFuncAsDllEntry index szDllName szProcName iptr =
+  do
+    szDllName <- marshallWideString szDllName
+    szProcName <- marshallWideString szProcName
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_defineFuncAsDllEntry methPtr iptr index szDllName szProcName) 18 iptr
+    freeWideString szDllName
+    freeWideString szProcName
+
+foreign import stdcall "dynamic" prim_TypeLib_defineFuncAsDllEntry :: Ptr () -> Ptr () -> Word32 -> Ptr WideString -> Ptr WideString -> IO Int32
+setFuncDocString :: UINT
+                 -> LPOLESTR
+                 -> ICreateTypeInfo a0
+                 -> IO ()
+setFuncDocString index szDocString iptr =
+  do
+    szDocString <- marshallWideString szDocString
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setVarName methPtr iptr index szDocString) 19 iptr
+    freeWideString szDocString
+
+setVarDocString :: UINT
+                -> LPOLESTR
+                -> ICreateTypeInfo a0
+                -> IO ()
+setVarDocString index szDocString iptr =
+  do
+    szDocString <- marshallWideString szDocString
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setVarName methPtr iptr index szDocString) 20 iptr
+    freeWideString szDocString
+
+setFuncHelpContext :: UINT
+                   -> DWORD
+                   -> ICreateTypeInfo a0
+                   -> IO ()
+setFuncHelpContext index dwHelpContext0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_addImplType methPtr iptr index dwHelpContext0)
+                 21
+                 iptr
+
+setVarHelpContext :: UINT
+                  -> DWORD
+                  -> ICreateTypeInfo a0
+                  -> IO ()
+setVarHelpContext index dwHelpContext0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_addImplType methPtr iptr index dwHelpContext0)
+                 22
+                 iptr
+
+setMops :: UINT
+        -> String
+        -> ICreateTypeInfo a0
+        -> IO ()
+setMops index bstrMops iptr =
+  do
+    bstrMops <- marshallBSTR bstrMops
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setMops methPtr iptr index bstrMops) 23 iptr
+    freeBSTR bstrMops
+
+foreign import stdcall "dynamic" prim_TypeLib_setMops :: Ptr () -> Ptr () -> Word32 -> Ptr String -> IO Int32
+setTypeIdldesc :: IDLDESC
+               -> ICreateTypeInfo a0
+               -> IO ()
+setTypeIdldesc pIdlDesc iptr =
+  do
+    pIdlDesc <- marshallref (allocBytes (fromIntegral sizeofIDLDESC)) writeIDLDESC pIdlDesc
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeIdldesc methPtr iptr pIdlDesc) 24 iptr
+    free pIdlDesc
+
+foreign import stdcall "dynamic" prim_TypeLib_setTypeIdldesc :: Ptr () -> Ptr () -> Ptr IDLDESC -> IO Int32
+layOut :: ICreateTypeInfo a0
+       -> IO ()
+layOut iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_layOut methPtr iptr)
+                 25
+                 iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_layOut :: Ptr () -> Ptr () -> IO Int32
+-- --------------------------------------------------
+-- 
+-- interface ICreateTypeInfo2
+-- 
+-- --------------------------------------------------
+data ICreateTypeInfo2_ a = ICreateTypeInfo2__
+                             
+type ICreateTypeInfo2 a = ICreateTypeInfo (ICreateTypeInfo2_ a)
+iidICreateTypeInfo2 :: IID (ICreateTypeInfo2 ())
+iidICreateTypeInfo2 =
+  mkIID "{0002040E-0000-0000-C000-000000000046}"
+
+type LPCREATETYPEINFO2 = Maybe (ICreateTypeInfo2 ())
+deleteFuncDesc :: UINT
+               -> ICreateTypeInfo2 a0
+               -> IO ()
+deleteFuncDesc index iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeFlags methPtr iptr index)
+                 26
+                 iptr
+
+deleteFuncDescByMemId :: MEMBERID
+                      -> INVOKEKIND
+                      -> ICreateTypeInfo2 a0
+                      -> IO ()
+deleteFuncDescByMemId memid1 invKind iptr =
+  do
+    invKind <- marshallEnum32 invKind
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_deleteFuncDescByMemId methPtr iptr memid1 invKind) 27 iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_deleteFuncDescByMemId :: Ptr () -> Ptr () -> Int32 -> Int32 -> IO Int32
+deleteVarDesc :: UINT
+              -> ICreateTypeInfo2 a0
+              -> IO ()
+deleteVarDesc index iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeFlags methPtr iptr index)
+                 28
+                 iptr
+
+deleteVarDescByMemId :: MEMBERID
+                     -> ICreateTypeInfo2 a0
+                     -> IO ()
+deleteVarDescByMemId memid1 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_deleteVarDescByMemId methPtr iptr memid1)
+                 29
+                 iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_deleteVarDescByMemId :: Ptr () -> Ptr () -> Int32 -> IO Int32
+deleteImplType :: UINT
+               -> ICreateTypeInfo2 a0
+               -> IO ()
+deleteImplType index iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeFlags methPtr iptr index)
+                 30
+                 iptr
+
+setCustData :: REFGUID
+            -> VARIANT
+            -> ICreateTypeInfo2 a0
+            -> IO ()
+setCustData guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setCustData methPtr iptr guid1 pVarVal)) 31 iptr
+    free pVarVal
+
+foreign import stdcall "dynamic" prim_TypeLib_setCustData :: Ptr () -> Ptr () -> Ptr GUID -> VARIANT -> IO Int32
+setFuncCustData :: UINT
+                -> REFGUID
+                -> VARIANT
+                -> ICreateTypeInfo2 a0
+                -> IO ()
+setFuncCustData index guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 32 iptr
+    free pVarVal
+
+foreign import stdcall "dynamic" prim_TypeLib_setFuncCustData :: Ptr () -> Ptr () -> Word32 -> Ptr GUID -> VARIANT -> IO Int32
+setParamCustData :: UINT
+                 -> UINT
+                 -> REFGUID
+                 -> VARIANT
+                 -> ICreateTypeInfo2 a0
+                 -> IO ()
+setParamCustData indexFunc indexParam guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setParamCustData methPtr iptr indexFunc indexParam guid1 pVarVal)) 33 iptr
+    free pVarVal
+
+foreign import stdcall "dynamic" prim_TypeLib_setParamCustData :: Ptr () -> Ptr () -> Word32 -> Word32 -> Ptr GUID -> VARIANT -> IO Int32
+setVarCustData :: UINT
+               -> REFGUID
+               -> VARIANT
+               -> ICreateTypeInfo2 a0
+               -> IO ()
+setVarCustData index guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 34 iptr
+    free pVarVal
+
+setImplTypeCustData :: UINT
+                    -> REFGUID
+                    -> VARIANT
+                    -> ICreateTypeInfo2 a0
+                    -> IO ()
+setImplTypeCustData index guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 35 iptr
+    free pVarVal
+
+setHelpStringContext :: ULONG
+                     -> ICreateTypeInfo2 a0
+                     -> IO ()
+setHelpStringContext dwHelpStringContext iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeFlags methPtr iptr dwHelpStringContext)
+                 36
+                 iptr
+
+setFuncHelpStringContext :: UINT
+                         -> ULONG
+                         -> ICreateTypeInfo2 a0
+                         -> IO ()
+setFuncHelpStringContext index dwHelpStringContext iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_addImplType methPtr iptr index dwHelpStringContext)
+                 37
+                 iptr
+
+setVarHelpStringContext :: UINT
+                        -> ULONG
+                        -> ICreateTypeInfo2 a0
+                        -> IO ()
+setVarHelpStringContext index dwHelpStringContext iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_addImplType methPtr iptr index dwHelpStringContext)
+                 38
+                 iptr
+
+invalidate :: ICreateTypeInfo2 a0
+           -> IO ()
+invalidate iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_layOut methPtr iptr)
+                 39
+                 iptr
+
+setName :: LPOLESTR
+        -> ICreateTypeInfo2 a0
+        -> IO ()
+setName szName iptr =
+  do
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setDocString methPtr iptr szName) 40 iptr
+    freeWideString szName
+
+-- --------------------------------------------------
+-- 
+-- interface ICreateTypeLib
+-- 
+-- --------------------------------------------------
+data ICreateTypeLib_ a = ICreateTypeLib__
+                           
+type ICreateTypeLib a = IUnknown (ICreateTypeLib_ a)
+iidICreateTypeLib :: IID (ICreateTypeLib ())
+iidICreateTypeLib = mkIID "{00020406-0000-0000-C000-000000000046}"
+
+type LPCREATETYPELIB = Maybe (ICreateTypeLib ())
+createTypeInfo :: LPOLESTR
+               -> TYPEKIND
+               -> ICreateTypeLib a0
+               -> IO (ICreateTypeInfo ())
+createTypeInfo szName tkind iptr =
+  do
+    ppCTInfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    szName <- marshallWideString szName
+    tkind <- marshallEnum32 tkind
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_createTypeInfo methPtr iptr szName tkind ppCTInfo) 3 iptr
+    freeWideString szName
+    doThenFree free (readIUnknown False) ppCTInfo
+
+foreign import stdcall "dynamic" prim_TypeLib_createTypeInfo :: Ptr () -> Ptr () -> Ptr WideString -> Int32 -> Ptr (Ptr (ICreateTypeInfo a)) -> IO Int32
+setNameCTL :: LPOLESTR
+           -> ICreateTypeLib a0
+           -> IO ()
+setNameCTL szName iptr =
+  do
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setDocString methPtr iptr szName) 4 iptr
+    freeWideString szName
+
+setVersionCTL :: WORD
+              -> WORD
+              -> ICreateTypeLib a0
+              -> IO ()
+setVersionCTL wMajorVerNum0 wMinorVerNum0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setVersion methPtr iptr wMajorVerNum0 wMinorVerNum0)
+                 5
+                 iptr
+
+setGuidCTL :: REFGUID
+           -> ICreateTypeLib a0
+           -> IO ()
+setGuidCTL guid1 iptr =
+  do
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setGuid methPtr iptr guid1)) 6 iptr
+
+setDocStringCTL :: LPOLESTR
+                -> ICreateTypeLib a0
+                -> IO ()
+setDocStringCTL szDoc iptr =
+  do
+    szDoc <- marshallWideString szDoc
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setDocString methPtr iptr szDoc) 7 iptr
+    freeWideString szDoc
+
+setHelpFileName :: LPOLESTR
+                -> ICreateTypeLib a0
+                -> IO ()
+setHelpFileName szHelpFileName iptr =
+  do
+    szHelpFileName <- marshallWideString szHelpFileName
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setDocString methPtr iptr szHelpFileName) 8 iptr
+    freeWideString szHelpFileName
+
+setHelpContextCTL :: DWORD
+                  -> ICreateTypeLib a0
+                  -> IO ()
+setHelpContextCTL dwHelpContext0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeFlags methPtr iptr dwHelpContext0)
+                 9
+                 iptr
+
+setLcid :: LCID
+        -> ICreateTypeLib a0
+        -> IO ()
+setLcid lcid0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeFlags methPtr iptr lcid0)
+                 10
+                 iptr
+
+setLibFlags :: UINT
+            -> ICreateTypeLib a0
+            -> IO ()
+setLibFlags uLibFlags iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeFlags methPtr iptr uLibFlags)
+                 11
+                 iptr
+
+saveAllChanges :: ICreateTypeLib a0
+               -> IO ()
+saveAllChanges iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_layOut methPtr iptr)
+                 12
+                 iptr
+
+-- --------------------------------------------------
+-- 
+-- interface ICreateTypeLib2
+-- 
+-- --------------------------------------------------
+data ICreateTypeLib2_ a = ICreateTypeLib2__
+                            
+type ICreateTypeLib2 a = ICreateTypeLib (ICreateTypeLib2_ a)
+iidICreateTypeLib2 :: IID (ICreateTypeLib2 ())
+iidICreateTypeLib2 = mkIID "{0002040F-0000-0000-C000-000000000046}"
+
+type LPCREATETYPELIB2 = Maybe (ICreateTypeLib2 ())
+deleteTypeInfo :: LPOLESTR
+               -> ICreateTypeLib2 a0
+               -> IO ()
+deleteTypeInfo szName iptr =
+  do
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setDocString methPtr iptr szName) 13 iptr
+    freeWideString szName
+
+setCustDataCTL :: REFGUID
+               -> VARIANT
+               -> ICreateTypeLib2 a0
+               -> IO ()
+setCustDataCTL guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setCustData methPtr iptr guid1 pVarVal)) 14 iptr
+    free pVarVal
+
+setHelpStringContextCTL :: ULONG
+                        -> ICreateTypeLib2 a0
+                        -> IO ()
+setHelpStringContextCTL dwHelpStringContext iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setTypeFlags methPtr iptr dwHelpStringContext)
+                 15
+                 iptr
+
+setHelpStringDll :: LPOLESTR
+                 -> ICreateTypeLib2 a0
+                 -> IO ()
+setHelpStringDll szFileName iptr =
+  do
+    szFileName <- marshallWideString szFileName
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_setDocString methPtr iptr szFileName) 16 iptr
+    freeWideString szFileName
+
+{- BEGIN_C_CODE
+/* DISPID reserved to indicate an "unknown" name */
+END_C_CODE-}
+{- BEGIN_C_CODE
+/* only reserved for data members (properties); reused as a method dispid below */
+END_C_CODE-}
+dISPID_UNKNOWN :: DISPID
+dISPID_UNKNOWN = (negate 1)
+
+{- BEGIN_C_CODE
+/* DISPID reserved for the "value" property */
+END_C_CODE-}
+dISPID_VALUE :: DISPID
+dISPID_VALUE = 0
+
+{- BEGIN_C_CODE
+/* The following DISPID is reserved to indicate the param
+END_C_CODE-}
+{- BEGIN_C_CODE
+ * that is the right-hand-side (or "put" value) of a PropertyPut
+END_C_CODE-}
+{- BEGIN_C_CODE
+ */
+END_C_CODE-}
+dISPID_PROPERTYPUT :: DISPID
+dISPID_PROPERTYPUT = (negate 3)
+
+{- BEGIN_C_CODE
+/* DISPID reserved for the standard "NewEnum" method */
+END_C_CODE-}
+dISPID_NEWENUM :: DISPID
+dISPID_NEWENUM = (negate 4)
+
+{- BEGIN_C_CODE
+/* DISPID reserved for the standard "Evaluate" method */
+END_C_CODE-}
+dISPID_EVALUATE :: DISPID
+dISPID_EVALUATE = (negate 5)
+
+dISPID_CONSTRUCTOR :: DISPID
+dISPID_CONSTRUCTOR = (negate 6)
+
+dISPID_DESTRUCTOR :: DISPID
+dISPID_DESTRUCTOR = (negate 7)
+
+dISPID_COLLECT :: DISPID
+dISPID_COLLECT = (negate 8)
+
+-- --------------------------------------------------
+-- 
+-- interface ITypeComp
+-- 
+-- --------------------------------------------------
+data ITypeComp_ a = ITypeComp__
+                      
+type ITypeComp a = IUnknown (ITypeComp_ a)
+iidITypeComp :: IID (ITypeComp ())
+iidITypeComp = mkIID "{00020403-0000-0000-C000-000000000046}"
+
+type LPTYPECOMP = Maybe (ITypeComp ())
+data DESCKIND
+ = DESCKIND_NONE
+ | DESCKIND_FUNCDESC
+ | DESCKIND_VARDESC
+ | DESCKIND_TYPECOMP
+ | DESCKIND_IMPLICITAPPOBJ
+ | DESCKIND_MAX
+ deriving (Enum)
+data BINDPTR
+ = Lpfuncdesc (Maybe FUNCDESC)
+ | Lpvardesc (Maybe VARDESC)
+ | Lptcomp (ITypeComp ())
+ 
+marshallBINDPTR :: BINDPTR
+                -> IO (BINDPTR, Int32)
+marshallBINDPTR = marshallUnion "marshallBINDPTR"
+
+unmarshallBINDPTR :: BINDPTR
+                  -> Int32
+                  -> IO BINDPTR
+unmarshallBINDPTR = unmarshallUnion "unmarshallBINDPTR"
+
+writeBINDPTR :: Bool
+             -> (Int32 -> IO ())
+             -> Ptr BINDPTR
+             -> BINDPTR
+             -> IO ()
+writeBINDPTR addRefMe__ write_tag ptr v =
+  case v of
+     (Lpfuncdesc lpfuncdesc) -> do
+                                  write_tag (-1)
+                                  writeunique (allocBytes (fromIntegral sizeofFUNCDESC)) writeFUNCDESC (castPtr ptr) lpfuncdesc
+     (Lpvardesc lpvardesc) -> do
+                                write_tag (-1)
+                                writeunique (allocBytes (fromIntegral sizeofVARDESC)) writeVARDESC (castPtr ptr) lpvardesc
+     (Lptcomp lptcomp) -> do
+                            write_tag (-1)
+                            writeIUnknown addRefMe__ (castPtr ptr) lptcomp
+
+readBINDPTR :: Bool
+            -> IO Int32
+            -> Ptr BINDPTR
+            -> IO BINDPTR
+readBINDPTR finaliseMe__ read_tag ptr =
+  error "readBINDPTR: I am the walrus."
+
+sizeofBINDPTR :: Word32
+sizeofBINDPTR = 4
+
+freeBINDPTR :: Int32
+            -> Ptr BINDPTR
+            -> IO ()
+freeBINDPTR read_tag ptr = error "freeBINDPTR: I am the walrus."
+
+type LPBINDPTR = BINDPTR
+bind :: LPOLESTR
+     -> ULONG
+     -> WORD
+     -> ITypeComp a0
+     -> IO (ITypeInfo (), DESCKIND, BINDPTR)
+bind szName lHashVal wFlags iptr =
+  do
+    ppTInfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    pDescKind <- allocBytes (fromIntegral sizeofInt32)
+    pBindPtr <- allocBytes (fromIntegral sizeofBINDPTR)
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_bind methPtr iptr szName lHashVal wFlags ppTInfo pDescKind pBindPtr) 3 iptr
+    freeWideString szName
+    ppTInfo <- doThenFree free (readIUnknown False) ppTInfo
+    pDescKind <- doThenFree free readEnum32 pDescKind
+    pBindPtr <- doThenFree free (readBINDPTR False (return ((-1)))) pBindPtr
+    return (ppTInfo, pDescKind, pBindPtr)
+
+foreign import stdcall "dynamic" prim_TypeLib_bind :: Ptr () -> Ptr () -> Ptr WideString -> Word32 -> Word16 -> Ptr (Ptr (ITypeInfo a)) -> Ptr DESCKIND -> Ptr BINDPTR -> IO Int32
+bindType :: LPOLESTR
+         -> ULONG
+         -> ITypeComp a0
+         -> IO (ITypeInfo (), ITypeComp ())
+bindType szName lHashVal iptr =
+  do
+    ppTInfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    ppTComp <- allocBytes (fromIntegral sizeofForeignPtr)
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_bindType methPtr iptr szName lHashVal ppTInfo ppTComp) 4 iptr
+    freeWideString szName
+    ppTInfo <- doThenFree free (readIUnknown False) ppTInfo
+    ppTComp <- doThenFree free (readIUnknown False) ppTComp
+    return (ppTInfo, ppTComp)
+
+foreign import stdcall "dynamic" prim_TypeLib_bindType :: Ptr () -> Ptr () -> Ptr WideString -> Word32 -> Ptr (Ptr (ITypeInfo a)) -> Ptr (Ptr (ITypeComp a)) -> IO Int32
+-- --------------------------------------------------
+-- 
+-- interface ITypeInfo
+-- 
+-- --------------------------------------------------
+data ITypeInfo_ a = ITypeInfo__
+                      
+type ITypeInfo a = IUnknown (ITypeInfo_ a)
+iidITypeInfo :: IID (ITypeInfo ())
+iidITypeInfo = mkIID "{00020401-0000-0000-C000-000000000046}"
+
+type LPTYPEINFO = Maybe (ITypeInfo ())
+getTypeAttr :: ITypeInfo a0
+            -> IO (Maybe TYPEATTR)
+getTypeAttr iptr =
+  do
+    ppTypeAttr <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getTypeAttr methPtr iptr ppTypeAttr) 3 iptr
+    doThenFree free (readunique (readTYPEATTR False)) ppTypeAttr
+
+foreign import stdcall "dynamic" prim_TypeLib_getTypeAttr :: Ptr () -> Ptr () -> Ptr (Ptr TYPEATTR) -> IO Int32
+getTypeComp :: ITypeInfo a0
+            -> IO (ITypeComp ())
+getTypeComp iptr =
+  do
+    ppTComp <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getTypeComp methPtr iptr ppTComp) 4 iptr
+    doThenFree free (readIUnknown False) ppTComp
+
+foreign import stdcall "dynamic" prim_TypeLib_getTypeComp :: Ptr () -> Ptr () -> Ptr (Ptr (ITypeComp a)) -> IO Int32
+getFuncDesc :: UINT
+            -> ITypeInfo a0
+            -> IO (Maybe FUNCDESC)
+getFuncDesc index iptr =
+  do
+    ppFuncDesc <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getFuncDesc methPtr iptr index ppFuncDesc) 5 iptr
+    doThenFree free (readunique readFUNCDESC) ppFuncDesc
+
+foreign import stdcall "dynamic" prim_TypeLib_getFuncDesc :: Ptr () -> Ptr () -> Word32 -> Ptr (Ptr FUNCDESC) -> IO Int32
+getVarDesc :: UINT
+           -> ITypeInfo a0
+           -> IO (Maybe VARDESC)
+getVarDesc index iptr =
+  do
+    ppVarDesc <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getVarDesc methPtr iptr index ppVarDesc) 6 iptr
+    doThenFree free (readunique readVARDESC) ppVarDesc
+
+foreign import stdcall "dynamic" prim_TypeLib_getVarDesc :: Ptr () -> Ptr () -> Word32 -> Ptr (Ptr VARDESC) -> IO Int32
+getNames :: MEMBERID
+         -> UINT
+         -> ITypeInfo a0
+         -> IO [String]
+getNames memid1 cMaxNames iptr =
+  do
+    rgBstrNames <- allocBytes ((fromIntegral sizeofPtr * fromIntegral cMaxNames))
+    pcNames <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getNames methPtr iptr memid1 rgBstrNames cMaxNames pcNames) 7 iptr
+    cMaxNames <- unmarshallWord32 cMaxNames
+    pcNames <- readWord32 pcNames
+    let pcNames' = (pcNames)
+    doThenFree free (unmarshalllist sizeofPtr 0 ((fromIntegral ((pcNames')) :: Word32)) readBSTR) rgBstrNames
+
+foreign import stdcall "dynamic" prim_TypeLib_getNames :: Ptr () -> Ptr () -> Int32 -> Ptr String -> Word32 -> Ptr Word32 -> IO Int32
+getRefTypeOfImplType :: UINT
+                     -> ITypeInfo a0
+                     -> IO HREFTYPE
+getRefTypeOfImplType index iptr =
+  do
+    pRefType <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getRefTypeOfImplType methPtr iptr index pRefType) 8 iptr
+    doThenFree free readWord32 pRefType
+
+foreign import stdcall "dynamic" prim_TypeLib_getRefTypeOfImplType :: Ptr () -> Ptr () -> Word32 -> Ptr Word32 -> IO Int32
+getImplTypeFlags :: UINT
+                 -> ITypeInfo a0
+                 -> IO INT
+getImplTypeFlags index iptr =
+  do
+    pImplTypeFlags <- allocBytes (fromIntegral sizeofInt32)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getImplTypeFlags methPtr iptr index pImplTypeFlags) 9 iptr
+    doThenFree free readInt32 pImplTypeFlags
+
+foreign import stdcall "dynamic" prim_TypeLib_getImplTypeFlags :: Ptr () -> Ptr () -> Word32 -> Ptr Int32 -> IO Int32
+getIDsOfNames :: [LPOLESTR]
+              -> ITypeInfo a0
+              -> IO [MEMBERID]
+getIDsOfNames rgszNames iptr =
+  let
+   cNames = (fromIntegral (length rgszNames) :: Word32)
+  in
+  do
+    rgszNames <- marshalllist sizeofPtr writeWideString rgszNames
+    pMemId <- allocBytes ((fromIntegral sizeofInt32 * fromIntegral cNames))
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getIDsOfNames methPtr iptr rgszNames cNames pMemId) 10 iptr
+    free rgszNames
+    cNames <- unmarshallWord32 cNames
+    doThenFree (freeref trivialFree) (unmarshalllist sizeofInt32 0 ((fromIntegral cNames :: Word32)) readInt32) pMemId
+
+foreign import stdcall "dynamic" prim_TypeLib_getIDsOfNames :: Ptr () -> Ptr () -> Ptr (Ptr WideString) -> Word32 -> Ptr Int32 -> IO Int32
+invoke :: PVOID
+       -> MEMBERID
+       -> WORD
+       -> DISPPARAMS
+       -> ITypeInfo a0
+       -> IO (DISPPARAMS, VARIANT, EXCEPINFO, UINT)
+invoke pvInstance memid1 wFlags pDispParams iptr =
+  do
+    pVarResult <- allocVARIANT
+    pExcepInfo <- allocBytes (fromIntegral sizeofEXCEPINFO)
+    puArgErr <- allocBytes (fromIntegral sizeofWord32)
+    pDispParams <- marshallref (allocBytes (fromIntegral sizeofDISPPARAMS)) writeDISPPARAMS pDispParams
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_invoke methPtr iptr pvInstance memid1 wFlags pDispParams pVarResult pExcepInfo puArgErr) 11 iptr
+    pVarResult <- unmarshallVARIANT pVarResult
+    pExcepInfo <- doThenFree free readEXCEPINFO pExcepInfo
+    puArgErr <- doThenFree free readWord32 puArgErr
+    pDispParams <- doThenFree free readDISPPARAMS pDispParams
+    return (pDispParams, pVarResult, pExcepInfo, puArgErr)
+
+foreign import stdcall "dynamic" prim_TypeLib_invoke :: Ptr () -> Ptr () -> Ptr () -> Int32 -> Word16 -> Ptr DISPPARAMS -> VARIANT -> Ptr EXCEPINFO -> Ptr Word32 -> IO Int32
+getDocumentation :: MEMBERID
+                 -> ITypeInfo a0
+                 -> IO (String, String, DWORD, String)
+getDocumentation memid1 iptr =
+  do
+    pBstrName <- allocBytes (fromIntegral sizeofPtr)
+    pBstrDocString <- allocBytes (fromIntegral sizeofPtr)
+    pdwHelpContext <- allocBytes (fromIntegral sizeofWord32)
+    pBstrHelpFile <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getDocumentation methPtr iptr memid1 pBstrName pBstrDocString pdwHelpContext pBstrHelpFile) 12 iptr
+    pBstrName <- doThenFree (freeref freeBSTR) readBSTR pBstrName
+    pBstrDocString <- doThenFree (freeref freeBSTR) readBSTR pBstrDocString
+    pdwHelpContext <- doThenFree free readWord32 pdwHelpContext
+    pBstrHelpFile <- doThenFree (freeref freeBSTR) readBSTR pBstrHelpFile
+    return (pBstrName, pBstrDocString, pdwHelpContext, pBstrHelpFile)
+
+foreign import stdcall "dynamic" prim_TypeLib_getDocumentation :: Ptr () -> Ptr () -> Int32 -> Ptr String -> Ptr String -> Ptr Word32 -> Ptr String -> IO Int32
+getDllEntry :: MEMBERID
+            -> INVOKEKIND
+            -> ITypeInfo a0
+            -> IO (String, String, WORD)
+getDllEntry memid1 invKind iptr =
+  do
+    pBstrDllName <- allocBytes (fromIntegral sizeofPtr)
+    pBstrName <- allocBytes (fromIntegral sizeofPtr)
+    pwOrdinal <- allocBytes (fromIntegral sizeofWord16)
+    invKind <- marshallEnum32 invKind
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getDllEntry methPtr iptr memid1 invKind pBstrDllName pBstrName pwOrdinal) 13 iptr
+    pBstrDllName <- doThenFree (freeref freeBSTR) readBSTR pBstrDllName
+    pBstrName <- doThenFree (freeref freeBSTR) readBSTR pBstrName
+    pwOrdinal <- doThenFree free readWord16 pwOrdinal
+    return (pBstrDllName, pBstrName, pwOrdinal)
+
+foreign import stdcall "dynamic" prim_TypeLib_getDllEntry :: Ptr () -> Ptr () -> Int32 -> Int32 -> Ptr String -> Ptr String -> Ptr Word16 -> IO Int32
+getRefTypeInfo :: HREFTYPE
+               -> ITypeInfo a0
+               -> IO (ITypeInfo ())
+getRefTypeInfo hRefType iptr =
+  do
+    ppTInfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getRefTypeInfo methPtr iptr hRefType ppTInfo) 14 iptr
+    doThenFree free (readIUnknown False) ppTInfo
+
+foreign import stdcall "dynamic" prim_TypeLib_getRefTypeInfo :: Ptr () -> Ptr () -> Word32 -> Ptr (Ptr (ITypeInfo a)) -> IO Int32
+addressOfMember :: MEMBERID
+                -> INVOKEKIND
+                -> ITypeInfo a0
+                -> IO PVOID
+addressOfMember memid1 invKind iptr =
+  do
+    ppv <- allocBytes (fromIntegral sizeofPtr)
+    invKind <- marshallEnum32 invKind
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_addressOfMember methPtr iptr memid1 invKind ppv) 15 iptr
+    doThenFree free readPtr ppv
+
+foreign import stdcall "dynamic" prim_TypeLib_addressOfMember :: Ptr () -> Ptr () -> Int32 -> Int32 -> Ptr (Ptr ()) -> IO Int32
+createInstance :: IUnknown a2
+               -> IID a3
+               -> ITypeInfo a0
+               -> IO (IUnknown a1)
+createInstance pUnkOuter riid iptr =
+  do
+    ppvObj <- allocBytes (fromIntegral sizeofForeignPtr)
+    pUnkOuter <- marshallIUnknown pUnkOuter
+    riid <- marshallIID riid
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr pUnkOuter (\ pUnkOuter -> withForeignPtr riid (\ riid -> prim_TypeLib_createInstance methPtr iptr pUnkOuter riid ppvObj))) 16 iptr
+    doThenFree free (readIUnknown False) ppvObj
+
+foreign import stdcall "dynamic" prim_TypeLib_createInstance :: Ptr () -> Ptr () -> Ptr (IUnknown a) -> Ptr (IID a) -> Ptr (Ptr (IUnknown a)) -> IO Int32
+getMops :: MEMBERID
+        -> ITypeInfo a0
+        -> IO String
+getMops memid1 iptr =
+  do
+    pBstrMops <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getMops methPtr iptr memid1 pBstrMops) 17 iptr
+    doThenFree (freeref freeBSTR) readBSTR pBstrMops
+
+foreign import stdcall "dynamic" prim_TypeLib_getMops :: Ptr () -> Ptr () -> Int32 -> Ptr String -> IO Int32
+getContainingTypeLib :: ITypeInfo a0
+                     -> IO (ITypeLib (), UINT)
+getContainingTypeLib iptr =
+  do
+    ppTLib <- allocBytes (fromIntegral sizeofForeignPtr)
+    pIndex <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getContainingTypeLib methPtr iptr ppTLib pIndex) 18 iptr
+    ppTLib <- doThenFree free (readIUnknown False) ppTLib
+    pIndex <- doThenFree free readWord32 pIndex
+    return (ppTLib, pIndex)
+
+foreign import stdcall "dynamic" prim_TypeLib_getContainingTypeLib :: Ptr () -> Ptr () -> Ptr (Ptr (ITypeLib a)) -> Ptr Word32 -> IO Int32
+releaseTypeAttr :: Ptr TYPEATTR
+                -> ITypeInfo a0
+                -> IO ()
+releaseTypeAttr pTypeAttr iptr =
+  invokeIt (\ methPtr iptr -> prim_TypeLib_releaseTypeAttr methPtr iptr pTypeAttr)
+           19
+           iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_releaseTypeAttr :: Ptr () -> Ptr () -> Ptr TYPEATTR -> IO ()
+releaseFuncDesc :: Ptr FUNCDESC
+                -> ITypeInfo a0
+                -> IO ()
+releaseFuncDesc pFuncDesc iptr =
+  invokeIt (\ methPtr iptr -> prim_TypeLib_releaseFuncDesc methPtr iptr pFuncDesc)
+           20
+           iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_releaseFuncDesc :: Ptr () -> Ptr () -> Ptr FUNCDESC -> IO ()
+releaseVarDesc :: Ptr VARDESC
+               -> ITypeInfo a0
+               -> IO ()
+releaseVarDesc pVarDesc iptr =
+  invokeIt (\ methPtr iptr -> prim_TypeLib_releaseVarDesc methPtr iptr pVarDesc)
+           21
+           iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_releaseVarDesc :: Ptr () -> Ptr () -> Ptr VARDESC -> IO ()
+-- --------------------------------------------------
+-- 
+-- interface ITypeInfo2
+-- 
+-- --------------------------------------------------
+data ITypeInfo2_ a = ITypeInfo2__
+                       
+type ITypeInfo2 a = ITypeInfo (ITypeInfo2_ a)
+iidITypeInfo2 :: IID (ITypeInfo2 ())
+iidITypeInfo2 = mkIID "{00020412-0000-0000-C000-000000000046}"
+
+type LPTYPEINFO2 = Maybe (ITypeInfo2 ())
+getTypeKind :: ITypeInfo2 a0
+            -> IO TYPEKIND
+getTypeKind iptr =
+  do
+    pTypeKind <- allocBytes (fromIntegral sizeofInt32)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getTypeKind methPtr iptr pTypeKind) 22 iptr
+    doThenFree free readEnum32 pTypeKind
+
+foreign import stdcall "dynamic" prim_TypeLib_getTypeKind :: Ptr () -> Ptr () -> Ptr TYPEKIND -> IO Int32
+getTypeFlags :: ITypeInfo2 a0
+             -> IO ULONG
+getTypeFlags iptr =
+  do
+    pTypeFlags <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getTypeFlags methPtr iptr pTypeFlags) 23 iptr
+    doThenFree free readWord32 pTypeFlags
+
+foreign import stdcall "dynamic" prim_TypeLib_getTypeFlags :: Ptr () -> Ptr () -> Ptr Word32 -> IO Int32
+getFuncIndexOfMemId :: MEMBERID
+                    -> INVOKEKIND
+                    -> ITypeInfo2 a0
+                    -> IO UINT
+getFuncIndexOfMemId memid1 invKind iptr =
+  do
+    pFuncIndex <- allocBytes (fromIntegral sizeofWord32)
+    invKind <- marshallEnum32 invKind
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getFuncIndexOfMemId methPtr iptr memid1 invKind pFuncIndex) 24 iptr
+    doThenFree free readWord32 pFuncIndex
+
+foreign import stdcall "dynamic" prim_TypeLib_getFuncIndexOfMemId :: Ptr () -> Ptr () -> Int32 -> Int32 -> Ptr Word32 -> IO Int32
+getVarIndexOfMemId :: MEMBERID
+                   -> ITypeInfo2 a0
+                   -> IO UINT
+getVarIndexOfMemId memid1 iptr =
+  do
+    pVarIndex <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getVarIndexOfMemId methPtr iptr memid1 pVarIndex) 25 iptr
+    doThenFree free readWord32 pVarIndex
+
+foreign import stdcall "dynamic" prim_TypeLib_getVarIndexOfMemId :: Ptr () -> Ptr () -> Int32 -> Ptr Word32 -> IO Int32
+getCustData :: REFGUID
+            -> ITypeInfo2 a0
+            -> IO VARIANT
+getCustData guid1 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setCustData methPtr iptr guid1 pVarVal)) 26 iptr
+    unmarshallVARIANT pVarVal
+
+getFuncCustData :: UINT
+                -> REFGUID
+                -> ITypeInfo2 a0
+                -> IO VARIANT
+getFuncCustData index guid1 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 27 iptr
+    unmarshallVARIANT pVarVal
+
+getParamCustData :: UINT
+                 -> UINT
+                 -> REFGUID
+                 -> ITypeInfo2 a0
+                 -> IO VARIANT
+getParamCustData indexFunc indexParam guid1 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setParamCustData methPtr iptr indexFunc indexParam guid1 pVarVal)) 28 iptr
+    unmarshallVARIANT pVarVal
+
+getVarCustData :: UINT
+               -> REFGUID
+               -> ITypeInfo2 a0
+               -> IO VARIANT
+getVarCustData index guid1 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 29 iptr
+    unmarshallVARIANT pVarVal
+
+getImplTypeCustData :: UINT
+                    -> REFGUID
+                    -> ITypeInfo2 a0
+                    -> IO VARIANT
+getImplTypeCustData index guid1 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 30 iptr
+    unmarshallVARIANT pVarVal
+
+getDocumentation2 :: MEMBERID
+                  -> LCID
+                  -> ITypeInfo2 a0
+                  -> IO (String, DWORD, String)
+getDocumentation2 memid1 lcid0 iptr =
+  do
+    pbstrHelpString <- allocBytes (fromIntegral sizeofPtr)
+    pdwHelpStringContext <- allocBytes (fromIntegral sizeofWord32)
+    pbstrHelpStringDll <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getDocumentation2 methPtr iptr memid1 lcid0 pbstrHelpString pdwHelpStringContext pbstrHelpStringDll) 31 iptr
+    pbstrHelpString <- doThenFree (freeref freeBSTR) readBSTR pbstrHelpString
+    pdwHelpStringContext <- doThenFree free readWord32 pdwHelpStringContext
+    pbstrHelpStringDll <- doThenFree (freeref freeBSTR) readBSTR pbstrHelpStringDll
+    return (pbstrHelpString, pdwHelpStringContext, pbstrHelpStringDll)
+
+foreign import stdcall "dynamic" prim_TypeLib_getDocumentation2 :: Ptr () -> Ptr () -> Int32 -> Word32 -> Ptr String -> Ptr Word32 -> Ptr String -> IO Int32
+getAllCustData :: ITypeInfo2 a0
+               -> IO CUSTDATA
+getAllCustData iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getAllCustData methPtr iptr pCustData) 32 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+foreign import stdcall "dynamic" prim_TypeLib_getAllCustData :: Ptr () -> Ptr () -> Ptr CUSTDATA -> IO Int32
+getAllFuncCustData :: UINT
+                   -> ITypeInfo2 a0
+                   -> IO CUSTDATA
+getAllFuncCustData index iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getAllFuncCustData methPtr iptr index pCustData) 33 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+foreign import stdcall "dynamic" prim_TypeLib_getAllFuncCustData :: Ptr () -> Ptr () -> Word32 -> Ptr CUSTDATA -> IO Int32
+getAllParamCustData :: UINT
+                    -> UINT
+                    -> ITypeInfo2 a0
+                    -> IO CUSTDATA
+getAllParamCustData indexFunc indexParam iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getAllParamCustData methPtr iptr indexFunc indexParam pCustData) 34 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+foreign import stdcall "dynamic" prim_TypeLib_getAllParamCustData :: Ptr () -> Ptr () -> Word32 -> Word32 -> Ptr CUSTDATA -> IO Int32
+getAllVarCustData :: UINT
+                  -> ITypeInfo2 a0
+                  -> IO CUSTDATA
+getAllVarCustData index iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getAllFuncCustData methPtr iptr index pCustData) 35 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+getAllImplTypeCustData :: UINT
+                       -> ITypeInfo2 a0
+                       -> IO CUSTDATA
+getAllImplTypeCustData index iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getAllFuncCustData methPtr iptr index pCustData) 36 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+-- --------------------------------------------------
+-- 
+-- interface ITypeLib
+-- 
+-- --------------------------------------------------
+data ITypeLib_ a = ITypeLib__
+                     
+type ITypeLib a = IUnknown (ITypeLib_ a)
+iidITypeLib :: IID (ITypeLib ())
+iidITypeLib = mkIID "{00020402-0000-0000-C000-000000000046}"
+
+data SYSKIND
+ = SYSKINDList__ [SYSKIND]
+ | SYS_WIN16
+ | SYS_WIN32
+ | SYS_MAC
+ 
+instance Flags (SYSKIND) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (SYSKIND) where
+  fromEnum v =
+    case v of
+       (SYSKINDList__ xs) -> orList (map fromEnum xs)
+       SYS_WIN16 -> 0
+       SYS_WIN32 -> 1
+       SYS_MAC -> 2
+  
+  toEnum v =
+    case v of
+       0 -> SYS_WIN16
+       1 -> SYS_WIN32
+       2 -> SYS_MAC
+       x -> SYSKINDList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                then Just (toEnum (fromIntegral val))
+                                                else Nothing) (pow2Series 3 0))
+       _ -> error "unmarshallSYSKIND: illegal enum value "
+  
+data LIBFLAGS
+ = LIBFLAGSList__ [LIBFLAGS]
+ | LIBFLAG_FRESTRICTED
+ | LIBFLAG_FCONTROL
+ | LIBFLAG_FHIDDEN
+ | LIBFLAG_FHASDISKIMAGE
+ 
+instance Flags (LIBFLAGS) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (LIBFLAGS) where
+  fromEnum v =
+    case v of
+       (LIBFLAGSList__ xs) -> orList (map fromEnum xs)
+       LIBFLAG_FRESTRICTED -> 1
+       LIBFLAG_FCONTROL -> 2
+       LIBFLAG_FHIDDEN -> 4
+       LIBFLAG_FHASDISKIMAGE -> 8
+  
+  toEnum v =
+    case v of
+       1 -> LIBFLAG_FRESTRICTED
+       2 -> LIBFLAG_FCONTROL
+       4 -> LIBFLAG_FHIDDEN
+       8 -> LIBFLAG_FHASDISKIMAGE
+       x -> LIBFLAGSList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                 then Just (toEnum (fromIntegral val))
+                                                 else Nothing) (pow2Series 4 1))
+       _ -> error "unmarshallLIBFLAGS: illegal enum value "
+  
+type LPTYPELIB = Maybe (ITypeLib ())
+data TLIBATTR = TagTLIBATTR {guid1 :: GUID,
+                             lcid0 :: LCID,
+                             syskind :: SYSKIND,
+                             wMajorVerNum0 :: WORD,
+                             wMinorVerNum0 :: WORD,
+                             wLibFlags :: WORD}
+                  
+writeTLIBATTR :: Ptr TLIBATTR
+              -> TLIBATTR
+              -> IO ()
+writeTLIBATTR ptr (TagTLIBATTR guid1 lcid0 syskind wMajorVerNum0 wMinorVerNum0 wLibFlags) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeGUID pf1 guid1
+    let pf2 = addNCastPtr pf1 16
+    writeWord32 pf2 lcid0
+    let pf3 = addNCastPtr pf2 4
+    writeEnum32 pf3 syskind
+    let pf4 = addNCastPtr pf3 4
+    writeWord16 pf4 wMajorVerNum0
+    let pf5 = addNCastPtr pf4 2
+    writeWord16 pf5 wMinorVerNum0
+    let pf6 = addNCastPtr pf5 2
+    writeWord16 pf6 wLibFlags
+
+readTLIBATTR :: Bool
+             -> Ptr TLIBATTR
+             -> IO TLIBATTR
+readTLIBATTR finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    guid1 <- readGUID finaliseMe__ pf1
+    let pf2 = addNCastPtr pf1 16
+    lcid0 <- readWord32 pf2
+    let pf3 = addNCastPtr pf2 4
+    syskind <- readEnum32 pf3
+    let pf4 = addNCastPtr pf3 4
+    wMajorVerNum0 <- readWord16 pf4
+    let pf5 = addNCastPtr pf4 2
+    wMinorVerNum0 <- readWord16 pf5
+    let pf6 = addNCastPtr pf5 2
+    wLibFlags <- readWord16 pf6
+    return (TagTLIBATTR guid1 lcid0 syskind wMajorVerNum0 wMinorVerNum0 wLibFlags)
+
+sizeofTLIBATTR :: Word32
+sizeofTLIBATTR = 32
+
+type LPTLIBATTR = TLIBATTR
+getTypeInfoCount :: ITypeLib a0
+                 -> IO UINT
+getTypeInfoCount iptr =
+  invokeIt (\ methPtr iptr -> prim_TypeLib_getTypeInfoCount methPtr iptr)
+           3
+           iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_getTypeInfoCount :: Ptr () -> Ptr () -> IO Word32
+getTypeInfo :: UINT
+            -> ITypeLib a0
+            -> IO (ITypeInfo ())
+getTypeInfo index iptr =
+  do
+    ppTInfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getRefTypeInfo methPtr iptr index ppTInfo) 4 iptr
+    doThenFree free (readIUnknown False) ppTInfo
+
+getTypeInfoType :: UINT
+                -> ITypeLib a0
+                -> IO TYPEKIND
+getTypeInfoType index iptr =
+  do
+    pTKind <- allocBytes (fromIntegral sizeofInt32)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getTypeInfoType methPtr iptr index pTKind) 5 iptr
+    doThenFree free readEnum32 pTKind
+
+foreign import stdcall "dynamic" prim_TypeLib_getTypeInfoType :: Ptr () -> Ptr () -> Word32 -> Ptr TYPEKIND -> IO Int32
+getTypeInfoOfGuid :: REFGUID
+                  -> ITypeLib a0
+                  -> IO (ITypeInfo ())
+getTypeInfoOfGuid guid2 iptr =
+  do
+    ppTinfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    guid2 <- marshallGUID guid2
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid2 (\ guid2 -> prim_TypeLib_getTypeInfoOfGuid methPtr iptr guid2 ppTinfo)) 6 iptr
+    doThenFree free (readIUnknown False) ppTinfo
+
+foreign import stdcall "dynamic" prim_TypeLib_getTypeInfoOfGuid :: Ptr () -> Ptr () -> Ptr GUID -> Ptr (Ptr (ITypeInfo a)) -> IO Int32
+getLibAttr :: ITypeLib a0
+           -> IO (Maybe TLIBATTR)
+getLibAttr iptr =
+  do
+    ppTLibAttr <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getLibAttr methPtr iptr ppTLibAttr) 7 iptr
+    doThenFree free (readunique (readTLIBATTR False)) ppTLibAttr
+
+foreign import stdcall "dynamic" prim_TypeLib_getLibAttr :: Ptr () -> Ptr () -> Ptr (Ptr TLIBATTR) -> IO Int32
+getTypeCompTL :: ITypeLib a0
+              -> IO (ITypeComp ())
+getTypeCompTL iptr =
+  do
+    ppTComp <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getTypeComp methPtr iptr ppTComp) 8 iptr
+    doThenFree free (readIUnknown False) ppTComp
+
+getDocumentationTL :: INT
+                   -> ITypeLib a0
+                   -> IO (String, String, DWORD, String)
+getDocumentationTL index iptr =
+  do
+    pBstrName <- allocBytes (fromIntegral sizeofPtr)
+    pBstrDocString <- allocBytes (fromIntegral sizeofPtr)
+    pdwHelpContext <- allocBytes (fromIntegral sizeofWord32)
+    pBstrHelpFile <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getDocumentation methPtr iptr index pBstrName pBstrDocString pdwHelpContext pBstrHelpFile) 9 iptr
+    pBstrName <- doThenFree (freeref freeBSTR) readBSTR pBstrName
+    pBstrDocString <- doThenFree (freeref freeBSTR) readBSTR pBstrDocString
+    pdwHelpContext <- doThenFree free readWord32 pdwHelpContext
+    pBstrHelpFile <- doThenFree (freeref freeBSTR) readBSTR pBstrHelpFile
+    return (pBstrName, pBstrDocString, pdwHelpContext, pBstrHelpFile)
+
+isName :: LPOLESTR
+       -> ULONG
+       -> ITypeLib a0
+       -> IO (LPOLESTR, BOOL)
+isName szNameBuf lHashVal iptr =
+  do
+    pfName <- allocBytes (fromIntegral sizeofInt32)
+    szNameBuf <- marshallWideString szNameBuf
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_isName methPtr iptr szNameBuf lHashVal pfName) 10 iptr
+    pfName <- doThenFree free readInt32 pfName
+    szNameBuf <- doThenFree freeWideString unmarshallWideString szNameBuf
+    return (szNameBuf, pfName)
+
+foreign import stdcall "dynamic" prim_TypeLib_isName :: Ptr () -> Ptr () -> Ptr WideString -> Word32 -> Ptr Int32 -> IO Int32
+findName :: LPOLESTR
+         -> ULONG
+         -> USHORT
+         -> ITypeLib a0
+         -> IO (LPOLESTR, [ITypeInfo ()], [MEMBERID])
+findName szNameBuf lHashVal pcFound iptr =
+  do
+    ppTInfo <- allocBytes ((fromIntegral sizeofForeignPtr * fromIntegral ((pcFound))))
+    rgMemId <- allocBytes ((fromIntegral sizeofInt32 * fromIntegral ((pcFound))))
+    szNameBuf <- marshallWideString szNameBuf
+    pcFound <- marshallref (allocBytes (fromIntegral sizeofWord16)) writeWord16 pcFound
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_findName methPtr iptr szNameBuf lHashVal ppTInfo rgMemId pcFound) 11 iptr
+    szNameBuf <- doThenFree freeWideString unmarshallWideString szNameBuf
+    pcFound <- readWord16 pcFound
+    let pcFound' = (pcFound)
+    ppTInfo <- doThenFree (freeref trivialFree) (unmarshalllist sizeofForeignPtr 0 ((fromIntegral ((pcFound')) :: Word32)) (readIUnknown False)) ppTInfo
+    rgMemId <- doThenFree (freeref trivialFree) (unmarshalllist sizeofInt32 0 ((fromIntegral ((pcFound')) :: Word32)) readInt32) rgMemId
+    return (szNameBuf, ppTInfo, rgMemId)
+
+foreign import stdcall "dynamic" prim_TypeLib_findName :: Ptr () -> Ptr () -> Ptr WideString -> Word32 -> Ptr (Ptr (ITypeInfo a)) -> Ptr Int32 -> Ptr Word16 -> IO Int32
+releaseTLibAttr :: Ptr TLIBATTR
+                -> ITypeLib a0
+                -> IO ()
+releaseTLibAttr pTLibAttr iptr =
+  invokeIt (\ methPtr iptr -> prim_TypeLib_releaseTLibAttr methPtr iptr pTLibAttr)
+           12
+           iptr
+
+foreign import stdcall "dynamic" prim_TypeLib_releaseTLibAttr :: Ptr () -> Ptr () -> Ptr TLIBATTR -> IO ()
+-- --------------------------------------------------
+-- 
+-- interface ITypeLib2
+-- 
+-- --------------------------------------------------
+data ITypeLib2_ a = ITypeLib2__
+                      
+type ITypeLib2 a = ITypeLib (ITypeLib2_ a)
+iidITypeLib2 :: IID (ITypeLib2 ())
+iidITypeLib2 = mkIID "{00020411-0000-0000-C000-000000000046}"
+
+type LPTYPELIB2 = Maybe (ITypeLib2 ())
+getCustDataTL :: GUID
+              -> ITypeLib2 a0
+              -> IO VARIANT
+getCustDataTL guid2 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid2 <- marshallGUID guid2
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid2 (\ guid2 -> prim_TypeLib_setCustData methPtr iptr guid2 pVarVal)) 13 iptr
+    unmarshallVARIANT pVarVal
+
+getLibStatistics :: ITypeLib2 a0
+                 -> IO (ULONG, ULONG)
+getLibStatistics iptr =
+  do
+    pcUniqueNames <- allocBytes (fromIntegral sizeofWord32)
+    pcchUniqueNames <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getLibStatistics methPtr iptr pcUniqueNames pcchUniqueNames) 14 iptr
+    pcUniqueNames <- doThenFree free readWord32 pcUniqueNames
+    pcchUniqueNames <- doThenFree free readWord32 pcchUniqueNames
+    return (pcUniqueNames, pcchUniqueNames)
+
+foreign import stdcall "dynamic" prim_TypeLib_getLibStatistics :: Ptr () -> Ptr () -> Ptr Word32 -> Ptr Word32 -> IO Int32
+getDocumentation2TL :: INT
+                    -> LCID
+                    -> ITypeLib2 a0
+                    -> IO (String, DWORD, String)
+getDocumentation2TL index lcid1 iptr =
+  do
+    pbstrHelpString <- allocBytes (fromIntegral sizeofPtr)
+    pdwHelpStringContext <- allocBytes (fromIntegral sizeofWord32)
+    pbstrHelpStringDll <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getDocumentation2 methPtr iptr index lcid1 pbstrHelpString pdwHelpStringContext pbstrHelpStringDll) 15 iptr
+    pbstrHelpString <- doThenFree (freeref freeBSTR) readBSTR pbstrHelpString
+    pdwHelpStringContext <- doThenFree free readWord32 pdwHelpStringContext
+    pbstrHelpStringDll <- doThenFree (freeref freeBSTR) readBSTR pbstrHelpStringDll
+    return (pbstrHelpString, pdwHelpStringContext, pbstrHelpStringDll)
+
+getAllCustDataTL :: ITypeLib2 a0
+                 -> IO CUSTDATA
+getAllCustDataTL iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_TypeLib_getAllCustData methPtr iptr pCustData) 16 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+-- --------------------------------------------------
+-- 
+-- interface ITypeChangeEvents
+-- 
+-- --------------------------------------------------
+data ITypeChangeEvents_ a = ITypeChangeEvents__
+                              
+type ITypeChangeEvents a = IUnknown (ITypeChangeEvents_ a)
+iidITypeChangeEvents :: IID (ITypeChangeEvents ())
+iidITypeChangeEvents =
+  mkIID "{00020410-0000-0000-C000-000000000046}"
+
+type LPTYPECHANGEEVENTS = Maybe (ITypeChangeEvents ())
+data CHANGEKIND
+ = CHANGEKIND_ADDMEMBER
+ | CHANGEKIND_DELETEMEMBER
+ | CHANGEKIND_SETNAMES
+ | CHANGEKIND_SETDOCUMENTATION
+ | CHANGEKIND_GENERAL
+ | CHANGEKIND_INVALIDATE
+ | CHANGEKIND_CHANGEFAILED
+ | CHANGEKIND_MAX
+ deriving (Enum)
+requestTypeChange :: CHANGEKIND
+                  -> ITypeInfo a1
+                  -> LPOLESTR
+                  -> ITypeChangeEvents a0
+                  -> IO INT
+requestTypeChange changeKind pTInfoBefore pStrName iptr =
+  do
+    pfCancel <- allocBytes (fromIntegral sizeofInt32)
+    changeKind <- marshallEnum32 changeKind
+    pTInfoBefore <- marshallIUnknown pTInfoBefore
+    pStrName <- marshallWideString pStrName
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr pTInfoBefore (\ pTInfoBefore -> prim_TypeLib_requestTypeChange methPtr iptr changeKind pTInfoBefore pStrName pfCancel)) 3 iptr
+    freeWideString pStrName
+    doThenFree free readInt32 pfCancel
+
+foreign import stdcall "dynamic" prim_TypeLib_requestTypeChange :: Ptr () -> Ptr () -> Int32 -> Ptr (ITypeInfo a) -> Ptr WideString -> Ptr Int32 -> IO Int32
+afterTypeChange :: CHANGEKIND
+                -> ITypeInfo a1
+                -> LPOLESTR
+                -> ITypeChangeEvents a0
+                -> IO ()
+afterTypeChange changeKind pTInfoAfter pStrName iptr =
+  do
+    changeKind <- marshallEnum32 changeKind
+    pTInfoAfter <- marshallIUnknown pTInfoAfter
+    pStrName <- marshallWideString pStrName
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr pTInfoAfter (\ pTInfoAfter -> prim_TypeLib_afterTypeChange methPtr iptr changeKind pTInfoAfter pStrName)) 4 iptr
+    freeWideString pStrName
+
+foreign import stdcall "dynamic" prim_TypeLib_afterTypeChange :: Ptr () -> Ptr () -> Int32 -> Ptr (ITypeInfo a) -> Ptr WideString -> IO Int32
+
+ comlib/TypeLib.idl view
@@ -0,0 +1,1251 @@+module TypeLib {
+import "StdTypes.idl";
+
+  cpp_quote("#include \"StdTypes.h\"");
+  cpp_quote("typedef void* VARIANT;");
+  cpp_quote("typedef void* BSTR;");
+  cpp_quote("typedef DWORD HRESULT;");
+  cpp_quote("typedef void* IUnknown;");
+
+typedef struct tagSAFEARRAYBOUND {
+    ULONG cElements;
+    LONG  lLbound;
+} SAFEARRAYBOUND, * LPSAFEARRAYBOUND;
+
+//TypeInfo stuff.
+
+typedef LONG DISPID;
+typedef DISPID MEMBERID;
+typedef DWORD HREFTYPE;
+
+typedef [v1_enum] enum tagTYPEKIND {
+    TKIND_ENUM = 0,
+    TKIND_RECORD,
+    TKIND_MODULE,
+    TKIND_INTERFACE,
+    TKIND_DISPATCH,
+    TKIND_COCLASS,
+    TKIND_ALIAS,
+    TKIND_UNION,
+    TKIND_MAX                   /* end of enum marker */
+} TYPEKIND;
+
+typedef struct tagTYPEDESC {
+    [switch_type(VARTYPE), switch_is(vt)] union {
+        [case(VT_PTR, VT_SAFEARRAY)] struct tagTYPEDESC * lptdesc;
+        [case(VT_CARRAY)] struct tagARRAYDESC * lpadesc;
+        [case(VT_USERDEFINED)] HREFTYPE hreftype;
+        [default] ;
+    };
+    VARTYPE vt;
+} TYPEDESC;
+
+typedef struct tagARRAYDESC {
+    TYPEDESC tdescElem;         /* element type */
+    USHORT cDims;               /* dimension count */
+    [size_is(cDims)] SAFEARRAYBOUND rgbounds[]; /* var len array of bounds */
+} ARRAYDESC;
+
+// Added sof.
+typedef VARIANT VARIANTARG;
+
+// parameter description
+
+typedef struct tagPARAMDESCEX {
+    ULONG cBytes;               /* size of this structure */
+    VARIANTARG varDefaultValue; /* default value of this parameter */
+} PARAMDESCEX;
+
+typedef [unique]PARAMDESCEX* LPPARAMDESCEX;
+
+typedef struct tagPARAMDESC {
+    LPPARAMDESCEX pparamdescex; /* valid if PARAMFLAG_FHASDEFAULT bit is set */
+    USHORT wParamFlags;         /* IN, OUT, etc */
+} PARAMDESC, * LPPARAMDESC;
+
+const USHORT PARAMFLAG_NONE         = 0x00;
+const USHORT PARAMFLAG_FIN          = 0x01;
+const USHORT PARAMFLAG_FOUT         = 0x02;
+const USHORT PARAMFLAG_FLCID        = 0x04;
+const USHORT PARAMFLAG_FRETVAL      = 0x08;
+const USHORT PARAMFLAG_FOPT         = 0x10;
+const USHORT PARAMFLAG_FHASDEFAULT  = 0x20;
+
+typedef struct tagIDLDESC {
+    ULONG dwReserved;
+    USHORT wIDLFlags;           /* IN, OUT, etc */
+} IDLDESC, * LPIDLDESC;
+
+const USHORT IDLFLAG_NONE    = PARAMFLAG_NONE;
+const USHORT IDLFLAG_FIN     = PARAMFLAG_FIN;
+const USHORT IDLFLAG_FOUT    = PARAMFLAG_FOUT;
+const USHORT IDLFLAG_FLCID   = PARAMFLAG_FLCID;
+const USHORT IDLFLAG_FRETVAL = PARAMFLAG_FRETVAL;
+
+cpp_quote("#if 0")
+cpp_quote("/* the following is what MIDL knows how to remote */")
+
+typedef struct tagELEMDESC {    /* a format that MIDL likes */
+    TYPEDESC tdesc;             /* the type of the element */
+    PARAMDESC paramdesc;        /* IDLDESC is a subset of PARAMDESC */
+} ELEMDESC;
+
+cpp_quote("#else /* 0 */")
+cpp_quote("typedef struct tagELEMDESC {")
+cpp_quote("    TYPEDESC tdesc;             /* the type of the element */")
+cpp_quote("    union {")
+cpp_quote("        IDLDESC idldesc;        /* info for remoting the element */")
+cpp_quote("        PARAMDESC paramdesc;    /* info about the parameter */")
+cpp_quote("    };")
+cpp_quote("} ELEMDESC, * LPELEMDESC;")
+cpp_quote("#endif /* 0 */")
+
+
+typedef [nofree]struct tagTYPEATTR {
+    GUID guid;                  /* the GUID of the TypeInfo */
+    LCID lcid;                  /* locale of member names and doc strings */
+    DWORD dwReserved;
+    MEMBERID memidConstructor;  /* ID of constructor, MEMBERID_NIL if none */
+    MEMBERID memidDestructor;   /* ID of destructor, MEMBERID_NIL if none */
+    LPOLESTR lpstrSchema;
+    ULONG cbSizeInstance;       /* the size of an instance of this type */
+    TYPEKIND typekind;          /* the kind of type this typeinfo describes */
+    WORD cFuncs;                /* number of functions */
+    WORD cVars;                 /* number of variables / data members */
+    WORD cImplTypes;            /* number of implemented interfaces */
+    WORD cbSizeVft;             /* the size of this types virtual func table */
+    WORD cbAlignment;           /* specifies the alignment requirements for
+                                   an instance of this type,
+                                   0 = align on 64k boundary
+                                   1 = byte align
+                                   2 = word align
+                                   4 = dword align... */
+    WORD wTypeFlags;
+    WORD wMajorVerNum;          /* major version number */
+    WORD wMinorVerNum;          /* minor version number */
+    TYPEDESC tdescAlias;        /* if typekind == TKIND_ALIAS this field
+                                   specifies the type for which this type
+                                   is an alias */
+    IDLDESC idldescType;        /* IDL attributes of the described type */
+} TYPEATTR, * LPTYPEATTR;
+
+typedef struct tagDISPPARAMS {
+    [size_is(cArgs)] VARIANTARG * rgvarg;
+    [size_is(cNamedArgs)] DISPID * rgdispidNamedArgs;
+    UINT cArgs;
+    UINT cNamedArgs;
+} DISPPARAMS;
+
+cpp_quote("#if 0")
+cpp_quote("/* the following is what MIDL knows how to remote */")
+
+typedef struct tagEXCEPINFO {
+    WORD  wCode;            /* An error code describing the error. */
+    WORD  wReserved;
+    BSTR  bstrSource;       /* A source of the exception */
+    BSTR  bstrDescription;  /* A description of the error */
+    BSTR  bstrHelpFile;     /* Fully qualified drive, path, and file name */
+    DWORD dwHelpContext;    /* help context of topic within the help file */
+    ULONG pvReserved;
+    ULONG pfnDeferredFillIn;
+    SCODE scode;
+} EXCEPINFO;
+
+cpp_quote("#else /* 0 */")
+cpp_quote("typedef struct tagEXCEPINFO {")
+cpp_quote("    WORD  wCode;")
+cpp_quote("    WORD  wReserved;")
+cpp_quote("    BSTR  bstrSource;")
+cpp_quote("    BSTR  bstrDescription;")
+cpp_quote("    BSTR  bstrHelpFile;")
+cpp_quote("    DWORD dwHelpContext;")
+cpp_quote("    PVOID pvReserved;")
+cpp_quote("    HRESULT (__stdcall *pfnDeferredFillIn)(struct tagEXCEPINFO *);")
+cpp_quote("    SCODE scode;")
+cpp_quote("} EXCEPINFO, * LPEXCEPINFO;")
+cpp_quote("#endif /* 0 */")
+
+typedef [v1_enum] enum tagCALLCONV {
+    CC_FASTCALL = 0,
+    CC_CDECL = 1,
+    CC_MSCPASCAL,
+    CC_PASCAL = CC_MSCPASCAL,
+    CC_MACPASCAL,
+    CC_STDCALL,
+    CC_FPFASTCALL,
+    CC_SYSCALL,
+    CC_MPWCDECL,
+    CC_MPWPASCAL,
+    CC_MAX          /* end of enum marker */
+} CALLCONV;
+
+typedef [v1_enum] enum tagFUNCKIND {
+    FUNC_VIRTUAL,
+    FUNC_PUREVIRTUAL,
+    FUNC_NONVIRTUAL,
+    FUNC_STATIC,
+    FUNC_DISPATCH
+} FUNCKIND;
+
+typedef [v1_enum] enum tagINVOKEKIND {
+    INVOKE_FUNC = 1,
+    INVOKE_PROPERTYGET = 2,
+    INVOKE_PROPERTYPUT = 4,
+    INVOKE_PROPERTYPUTREF = 8
+} INVOKEKIND;
+
+typedef [v1_enum] enum tagVARKIND {
+    VAR_PERINSTANCE,
+    VAR_STATIC,
+    VAR_CONST,
+    VAR_DISPATCH
+} VARKIND;
+
+typedef [nofree]struct tagFUNCDESC {
+    MEMBERID memid;
+    [size_is(cScodes)] SCODE * lprgscode;
+    [size_is(cParams)] ELEMDESC * lprgelemdescParam; /* array of param types */
+    FUNCKIND funckind;
+    INVOKEKIND invkind;
+    CALLCONV callconv;
+    SHORT cParams;
+    SHORT cParamsOpt;
+    SHORT oVft;
+    SHORT cScodes;
+    ELEMDESC elemdescFunc;
+    WORD wFuncFlags;
+} FUNCDESC, *LPFUNCDESC;
+
+/* IMPLTYPE Flags */
+const USHORT IMPLTYPEFLAG_FDEFAULT      = 0x1;
+const USHORT IMPLTYPEFLAG_FSOURCE       = 0x2;
+const USHORT IMPLTYPEFLAG_FRESTRICTED   = 0x4;
+const USHORT IMPLTYPEFLAG_FDEFAULTVTABLE= 0x8;
+
+
+typedef [nofree]struct tagVARDESC {
+    MEMBERID memid;
+    LPOLESTR lpstrSchema;
+    [switch_type(VARKIND), switch_is(varkind)] union {
+        /* offset of variable within the instance */
+        [case(VAR_PERINSTANCE, VAR_DISPATCH, VAR_STATIC)] ULONG oInst;
+        [case(VAR_CONST)] VARIANT * lpvarValue; /* the value of the constant */
+    };
+    ELEMDESC elemdescVar;
+    WORD     wVarFlags;
+    VARKIND  varkind;
+} VARDESC, * LPVARDESC;
+
+typedef enum tagTYPEFLAGS {
+    TYPEFLAG_FAPPOBJECT = 0x01,
+    TYPEFLAG_FCANCREATE = 0x02,
+    TYPEFLAG_FLICENSED = 0x04,
+    TYPEFLAG_FPREDECLID = 0x08,
+    TYPEFLAG_FHIDDEN = 0x10,
+    TYPEFLAG_FCONTROL = 0x20,
+    TYPEFLAG_FDUAL = 0x40,
+    TYPEFLAG_FNONEXTENSIBLE = 0x80,
+    TYPEFLAG_FOLEAUTOMATION = 0x100,
+    TYPEFLAG_FRESTRICTED = 0x200,
+    TYPEFLAG_FAGGREGATABLE = 0x400,
+    TYPEFLAG_FREPLACEABLE = 0x800,
+    TYPEFLAG_FDISPATCHABLE = 0x1000,
+    TYPEFLAG_FREVERSEBIND = 0x2000
+} TYPEFLAGS;
+
+typedef enum tagFUNCFLAGS {
+    FUNCFLAG_FRESTRICTED = 0x1,
+    FUNCFLAG_FSOURCE = 0x2,
+    FUNCFLAG_FBINDABLE = 0x4,
+    FUNCFLAG_FREQUESTEDIT = 0x8,
+    FUNCFLAG_FDISPLAYBIND = 0x10,
+    FUNCFLAG_FDEFAULTBIND = 0x20,
+    FUNCFLAG_FHIDDEN = 0x40,
+    FUNCFLAG_FUSESGETLASTERROR = 0x80,
+    FUNCFLAG_FDEFAULTCOLLELEM = 0x100,
+    FUNCFLAG_FUIDEFAULT = 0x200,
+    FUNCFLAG_FNONBROWSABLE = 0x400,
+    FUNCFLAG_FREPLACEABLE = 0x800,
+    FUNCFLAG_FIMMEDIATEBIND = 0x1000
+} FUNCFLAGS;
+
+typedef enum tagVARFLAGS {
+    VARFLAG_FREADONLY = 0x1,
+    VARFLAG_FSOURCE = 0x2,
+    VARFLAG_FBINDABLE = 0x4,
+    VARFLAG_FREQUESTEDIT = 0x8,
+    VARFLAG_FDISPLAYBIND = 0x10,
+    VARFLAG_FDEFAULTBIND = 0x20,
+    VARFLAG_FHIDDEN = 0x40,
+    VARFLAG_FRESTRICTED = 0x80,
+    VARFLAG_FDEFAULTCOLLELEM = 0x100,
+    VARFLAG_FUIDEFAULT = 0x200,
+    VARFLAG_FNONBROWSABLE = 0x400,
+    VARFLAG_FREPLACEABLE = 0x800,
+    VARFLAG_FIMMEDIATEBIND = 0x1000
+} VARFLAGS;
+
+typedef [wire_marshal(DWORD)] struct tagCLEANLOCALSTORAGE {
+    IUnknown * pInterface;      /* interface that is responsible for storage */
+    PVOID pStorage;             /* the storage being managed by interface */
+    DWORD flags;                /* which interface, what storage */
+} CLEANLOCALSTORAGE;
+
+typedef struct tagCUSTDATAITEM {
+    GUID guid;           /* guid identifying this custom data item */
+    VARIANTARG varValue; /* value of this custom data item */
+} CUSTDATAITEM, * LPCUSTDATAITEM;
+
+typedef struct tagCUSTDATA {
+    DWORD cCustData;            /* number of custom data items in rgCustData */
+    [size_is(cCustData)] LPCUSTDATAITEM prgCustData;
+                                /* array of custom data items */
+} CUSTDATA, * LPCUSTDATA;
+
+interface ITypeInfo;
+interface ITypeLib;
+
+[
+    object,
+    uuid(00020405-0000-0000-C000-000000000046),
+    pointer_default(unique),
+    local
+]
+
+interface ICreateTypeInfo: IUnknown
+{
+    typedef [unique] ICreateTypeInfo * LPCREATETYPEINFO;
+
+    HRESULT SetGuid(
+                [in] REFGUID guid
+            );
+
+    HRESULT SetTypeFlags(
+                [in] UINT uTypeFlags
+            );
+
+    HRESULT SetDocString(
+                [in] LPOLESTR pStrDoc
+            );
+
+    HRESULT SetHelpContext(
+                [in] DWORD dwHelpContext
+            );
+
+    HRESULT SetVersion(
+                [in] WORD wMajorVerNum,
+                [in] WORD wMinorVerNum
+            );
+
+    HRESULT AddRefTypeInfo(
+
+                [in] ITypeInfo * pTInfo,
+                [out] HREFTYPE * phRefType
+            );
+
+    HRESULT AddFuncDesc(
+                [in] UINT index,
+                [in] FUNCDESC * pFuncDesc
+            );
+
+    HRESULT AddImplType(
+                [in] UINT index,
+                [in] HREFTYPE hRefType
+            );
+
+    HRESULT SetImplTypeFlags(
+                [in] UINT index,
+                [in] INT implTypeFlags
+            );
+
+    HRESULT SetAlignment(
+                [in] WORD cbAlignment
+            );
+
+    HRESULT SetSchema(
+                [in] LPOLESTR pStrSchema
+            );
+
+    HRESULT AddVarDesc(
+                [in] UINT index,
+                [in] VARDESC * pVarDesc
+            );
+
+    HRESULT SetFuncAndParamNames(
+                [in] UINT index,
+                [in, size_is((UINT) cNames)]
+                [in] LPOLESTR * rgszNames,
+                [in] UINT cNames
+            );
+
+    HRESULT SetVarName(
+                [in] UINT index,
+                [in] LPOLESTR szName
+            );
+
+    HRESULT SetTypeDescAlias(
+                [in] TYPEDESC * pTDescAlias
+            );
+
+    HRESULT DefineFuncAsDllEntry(
+                [in] UINT index,
+                [in] LPOLESTR szDllName,
+                [in] LPOLESTR szProcName
+            );
+
+    HRESULT SetFuncDocString(
+                [in] UINT index,
+                [in] LPOLESTR szDocString
+            );
+
+    HRESULT SetVarDocString(
+                [in] UINT index,
+                [in] LPOLESTR szDocString
+            );
+
+    HRESULT SetFuncHelpContext(
+                [in] UINT index,
+                [in] DWORD dwHelpContext
+            );
+
+    HRESULT SetVarHelpContext(
+                [in] UINT index,
+                [in] DWORD dwHelpContext
+            );
+
+    HRESULT SetMops(
+                [in] UINT index,
+                [in] BSTR bstrMops
+            );
+
+    HRESULT SetTypeIdldesc(
+                [in] IDLDESC * pIdlDesc
+            );
+
+    HRESULT LayOut(
+                void
+            );
+
+}
+
+
+[
+    object,
+    uuid(0002040E-0000-0000-C000-000000000046),
+    pointer_default(unique),
+    local
+]
+
+interface ICreateTypeInfo2: ICreateTypeInfo
+{
+    typedef [unique] ICreateTypeInfo2 * LPCREATETYPEINFO2;
+
+    HRESULT DeleteFuncDesc(
+                [in] UINT index
+            );
+
+    HRESULT DeleteFuncDescByMemId(
+                [in] MEMBERID memid,
+                [in] INVOKEKIND invKind
+            );
+
+    HRESULT DeleteVarDesc(
+                [in] UINT index
+            );
+
+    HRESULT DeleteVarDescByMemId(
+                [in] MEMBERID memid
+            );
+
+    HRESULT DeleteImplType(
+                [in] UINT index
+            );
+
+    HRESULT SetCustData(
+                [in] REFGUID guid,
+                [in] VARIANT * pVarVal
+            );
+
+    HRESULT SetFuncCustData( 
+                [in] UINT index, 
+                [in] REFGUID guid, 
+                [in] VARIANT * pVarVal
+            );
+    
+    HRESULT SetParamCustData( 
+                [in] UINT indexFunc, 
+                [in] UINT indexParam, 
+                [in] REFGUID guid, 
+                [in] VARIANT * pVarVal
+            );
+
+    HRESULT SetVarCustData( 
+                [in] UINT index, 
+                [in] REFGUID guid, 
+                [in] VARIANT * pVarVal
+            );
+
+    HRESULT SetImplTypeCustData( 
+                [in] UINT index, 
+                [in] REFGUID guid, 
+                [in] VARIANT * pVarVal
+            );
+
+    HRESULT SetHelpStringContext(
+                [in] ULONG dwHelpStringContext
+            );
+
+    HRESULT SetFuncHelpStringContext(
+                [in] UINT index,
+                [in] ULONG dwHelpStringContext
+            );
+
+    HRESULT SetVarHelpStringContext(
+                [in] UINT index,
+                [in] ULONG dwHelpStringContext
+            );
+
+    HRESULT Invalidate(
+                void
+            );
+
+    HRESULT SetName(
+                [in]  LPOLESTR szName
+            );
+
+}
+
+
+[
+    object,
+    uuid(00020406-0000-0000-C000-000000000046),
+    pointer_default(unique),
+    local
+]
+
+interface ICreateTypeLib : IUnknown
+{
+    typedef [unique] ICreateTypeLib * LPCREATETYPELIB;
+
+    HRESULT CreateTypeInfo(
+                [in]  LPOLESTR szName,
+                [in]  TYPEKIND tkind,
+                [out] ICreateTypeInfo ** ppCTInfo
+            );
+
+    HRESULT SetName(
+                [in]  LPOLESTR szName
+            );
+
+    HRESULT SetVersion(
+                [in] WORD wMajorVerNum,
+                [in] WORD wMinorVerNum
+            );
+
+    HRESULT SetGuid(
+                [in] REFGUID guid
+            );
+
+    HRESULT SetDocString(
+                [in] LPOLESTR szDoc
+            );
+
+    HRESULT SetHelpFileName(
+                [in] LPOLESTR szHelpFileName
+            );
+
+    HRESULT SetHelpContext(
+                [in] DWORD dwHelpContext
+            );
+
+    HRESULT SetLcid(
+                [in] LCID lcid
+            );
+
+    HRESULT SetLibFlags(
+                [in] UINT uLibFlags
+            );
+
+    HRESULT SaveAllChanges(
+                void
+            );
+}
+
+
+[
+    object,
+    uuid(0002040F-0000-0000-C000-000000000046),
+    pointer_default(unique),
+    local
+]
+
+interface ICreateTypeLib2 : ICreateTypeLib
+{
+    typedef [unique] ICreateTypeLib2 * LPCREATETYPELIB2;
+
+    HRESULT DeleteTypeInfo(
+                [in] LPOLESTR szName
+            );
+
+    HRESULT SetCustData(
+                [in] REFGUID guid,
+                [in] VARIANT * pVarVal
+            );
+
+    HRESULT SetHelpStringContext(
+                [in] ULONG dwHelpStringContext
+            );
+
+    HRESULT SetHelpStringDll(
+                [in] LPOLESTR szFileName
+            );
+}
+
+cpp_quote("/* DISPID reserved to indicate an \"unknown\" name */")
+cpp_quote("/* only reserved for data members (properties); reused as a method dispid below */")
+const DISPID DISPID_UNKNOWN = -1;
+
+cpp_quote("/* DISPID reserved for the \"value\" property */")
+const DISPID DISPID_VALUE = 0;
+
+cpp_quote("/* The following DISPID is reserved to indicate the param")
+cpp_quote(" * that is the right-hand-side (or \"put\" value) of a PropertyPut")
+cpp_quote(" */")
+const DISPID DISPID_PROPERTYPUT = -3;
+
+cpp_quote("/* DISPID reserved for the standard \"NewEnum\" method */")
+const DISPID DISPID_NEWENUM = -4;
+
+cpp_quote("/* DISPID reserved for the standard \"Evaluate\" method */")
+const DISPID DISPID_EVALUATE = -5;
+
+const DISPID DISPID_CONSTRUCTOR = -6;
+
+const DISPID DISPID_DESTRUCTOR = -7;
+const DISPID DISPID_COLLECT = -8;
+
+[
+    object,
+    uuid(00020403-0000-0000-C000-000000000046),
+    pointer_default(unique)
+]
+
+interface ITypeComp : IUnknown
+{
+    typedef [unique] ITypeComp * LPTYPECOMP;
+
+    typedef [v1_enum] enum tagDESCKIND {
+        DESCKIND_NONE = 0,
+        DESCKIND_FUNCDESC,
+        DESCKIND_VARDESC,
+        DESCKIND_TYPECOMP,
+        DESCKIND_IMPLICITAPPOBJ,
+        DESCKIND_MAX
+    } DESCKIND;
+
+    typedef union tagBINDPTR {
+        FUNCDESC  * lpfuncdesc;
+        VARDESC   * lpvardesc;
+        ITypeComp * lptcomp;
+    } BINDPTR, * LPBINDPTR;
+
+    [local]
+    HRESULT Bind(
+                [in] LPOLESTR szName,
+                [in] ULONG lHashVal,
+                [in] WORD wFlags,
+                [out] ITypeInfo ** ppTInfo,
+                [out] DESCKIND * pDescKind,
+                [out] BINDPTR * pBindPtr
+            );
+
+    [call_as(Bind)]
+    HRESULT RemoteBind(
+                [in] LPOLESTR szName,
+                [in] ULONG lHashVal,
+                [in] WORD wFlags,
+                [out] ITypeInfo ** ppTInfo,
+                [out] DESCKIND * pDescKind,
+                [out] LPFUNCDESC * ppFuncDesc,
+                [out] LPVARDESC * ppVarDesc,
+                [out] ITypeComp ** ppTypeComp,
+                [out] CLEANLOCALSTORAGE * pDummy
+            );
+
+    [local]
+    HRESULT BindType(
+                [in] LPOLESTR szName,
+                [in] ULONG lHashVal,
+                [out] ITypeInfo ** ppTInfo,
+                [out] ITypeComp ** ppTComp
+            );
+
+    [call_as(BindType)]
+    HRESULT RemoteBindType(
+                [in] LPOLESTR szName,
+                [in] ULONG lHashVal,
+                [out] ITypeInfo ** ppTInfo
+            );
+}
+
+
+[
+    object,
+    uuid(00020401-0000-0000-C000-000000000046),
+    pointer_default(unique)
+]
+
+interface ITypeInfo : IUnknown
+{
+    typedef [unique] ITypeInfo * LPTYPEINFO;
+
+    [local]
+    HRESULT GetTypeAttr(
+                [out] TYPEATTR ** ppTypeAttr
+            );
+
+    [call_as(GetTypeAttr)]
+    HRESULT RemoteGetTypeAttr(
+                [out] LPTYPEATTR * ppTypeAttr,
+                [out] CLEANLOCALSTORAGE * pDummy
+            );
+
+    HRESULT GetTypeComp(
+                [out] ITypeComp ** ppTComp
+            );
+
+    [local]
+    HRESULT GetFuncDesc(
+                [in] UINT index,
+                [out] FUNCDESC ** ppFuncDesc
+            );
+
+    [call_as(GetFuncDesc)]
+    HRESULT RemoteGetFuncDesc(
+                [in] UINT index,
+                [out] LPFUNCDESC * ppFuncDesc,
+                [out] CLEANLOCALSTORAGE * pDummy
+            );
+
+    [local]
+    HRESULT GetVarDesc(
+                [in] UINT index,
+                [out] VARDESC ** ppVarDesc
+            );
+
+    [call_as(GetVarDesc)]
+    HRESULT RemoteGetVarDesc(
+                [in] UINT index,
+                [out] LPVARDESC * ppVarDesc,
+                [out] CLEANLOCALSTORAGE * pDummy
+            );
+
+    [local]
+    HRESULT GetNames(
+                [in] MEMBERID memid,
+                [out,size_is(cMaxNames),length_is(*pcNames)] BSTR * rgBstrNames,
+                [in] UINT cMaxNames,
+                [out] UINT * pcNames
+            );
+
+    [call_as(GetNames)]
+    HRESULT RemoteGetNames(
+                [in] MEMBERID memid,
+                [out,size_is(cMaxNames),length_is(*pcNames)] BSTR * rgBstrNames,
+                [in] UINT cMaxNames,
+                [out] UINT * pcNames
+            );
+
+    HRESULT GetRefTypeOfImplType(
+                [in] UINT index,
+                [out] HREFTYPE * pRefType
+            );
+
+    HRESULT GetImplTypeFlags(
+                [in] UINT index,
+                [out] INT * pImplTypeFlags
+            );
+
+    HRESULT GetIDsOfNames(
+                [in, size_is(cNames)] LPOLESTR * rgszNames,
+                [in] UINT cNames,
+                [out, size_is(cNames)] MEMBERID * pMemId
+            );
+
+    [local]
+    HRESULT Invoke(
+                [in] PVOID pvInstance,
+                [in] MEMBERID memid,
+                [in] WORD wFlags,
+                [in, out] DISPPARAMS * pDispParams,
+                [out] VARIANT * pVarResult,
+                [out] EXCEPINFO * pExcepInfo,
+                [out] UINT * puArgErr
+            );
+
+    [call_as(Invoke)]
+    HRESULT RemoteInvoke (
+                [in] IUnknown * pIUnk,
+                [in] MEMBERID memid,
+                [in] DWORD dwFlags,
+                [in] DISPPARAMS * pDispParams,
+                [out] VARIANT * pVarResult,
+                [out] EXCEPINFO * pExcepInfo,
+                [out] UINT * pArgErr,
+                [in] UINT cVarRef,
+                [in, size_is(cVarRef)] UINT * rgVarRefIdx,
+                [in, out, size_is(cVarRef)] VARIANTARG * rgVarRef
+            );
+
+    [local]
+    HRESULT GetDocumentation(
+                [in] MEMBERID memid,
+                [out] BSTR * pBstrName,
+                [out] BSTR * pBstrDocString,
+                [out] DWORD * pdwHelpContext,
+                [out] BSTR * pBstrHelpFile
+            );
+
+    [call_as(GetDocumentation)]
+    HRESULT RemoteGetDocumentation(
+                [in] MEMBERID memid,
+                [in] DWORD refPtrFlags,
+                [out] BSTR * pBstrName,
+                [out] BSTR * pBstrDocString,
+                [out] DWORD * pdwHelpContext,
+                [out] BSTR * pBstrHelpFile
+            );
+
+    [local]
+    HRESULT GetDllEntry(
+                [in] MEMBERID memid,
+                [in] INVOKEKIND invKind,
+                [out] BSTR * pBstrDllName,
+                [out] BSTR * pBstrName,
+                [out] WORD * pwOrdinal
+            );
+
+    [call_as(GetDllEntry)]
+    HRESULT RemoteGetDllEntry(
+                [in] MEMBERID memid,
+                [in] INVOKEKIND invKind,
+                [in] DWORD refPtrFlags,
+                [out] BSTR * pBstrDllName,
+                [out] BSTR * pBstrName,
+                [out] WORD * pwOrdinal
+            );
+
+    HRESULT GetRefTypeInfo(
+                [in] HREFTYPE hRefType,
+                [out] ITypeInfo ** ppTInfo
+            );
+
+    [local]
+    HRESULT AddressOfMember(
+                [in] MEMBERID memid,
+                [in] INVOKEKIND invKind,
+                [out] PVOID * ppv
+            );
+
+    [call_as(AddressOfMember)]
+    HRESULT LocalAddressOfMember(
+                void
+            );
+
+    [local]
+    HRESULT CreateInstance(
+                [in] IUnknown * pUnkOuter,
+                [in,ref] IID* riid,
+                [out, iid_is(riid)] PVOID * ppvObj
+            );
+
+    [call_as(CreateInstance)]
+    HRESULT RemoteCreateInstance(
+                [in,ref] IID* riid,
+                [out, iid_is(riid)] IUnknown ** ppvObj
+            );
+
+    HRESULT GetMops(
+                [in] MEMBERID memid,
+                [out] BSTR * pBstrMops
+            );
+
+    [local]
+    HRESULT GetContainingTypeLib(
+                [out] ITypeLib ** ppTLib,
+                [out] UINT * pIndex
+            );
+
+    [call_as(GetContainingTypeLib)]
+    HRESULT RemoteGetContainingTypeLib(
+                [out] ITypeLib ** ppTLib,
+                [out] UINT * pIndex
+            );
+
+    [local]
+    void ReleaseTypeAttr(
+                [in,ptr] TYPEATTR * pTypeAttr
+            );
+
+    [call_as(ReleaseTypeAttr)]
+    HRESULT LocalReleaseTypeAttr(
+                void
+            );
+
+    [local]
+    void ReleaseFuncDesc(
+                [in,ptr] FUNCDESC * pFuncDesc
+            );
+
+    [call_as(ReleaseFuncDesc)]
+    HRESULT LocalReleaseFuncDesc(
+                void
+            );
+
+    [local]
+    void ReleaseVarDesc(
+                [in,ptr] VARDESC * pVarDesc
+            );
+
+    [call_as(ReleaseVarDesc)]
+    HRESULT LocalReleaseVarDesc(
+                void
+            );
+}
+
+
+
+[
+    object,
+    uuid(00020412-0000-0000-C000-000000000046),
+    pointer_default(unique)
+]
+
+interface ITypeInfo2 : ITypeInfo
+{
+    typedef [unique] ITypeInfo2 * LPTYPEINFO2;
+
+    HRESULT GetTypeKind(
+                [out] TYPEKIND * pTypeKind
+            );
+
+    HRESULT GetTypeFlags(
+                [out] ULONG * pTypeFlags
+            );
+
+    HRESULT GetFuncIndexOfMemId(
+                [in] MEMBERID memid, 
+                [in] INVOKEKIND invKind, 
+                [out] UINT * pFuncIndex
+            );
+
+    HRESULT GetVarIndexOfMemId(
+                [in] MEMBERID memid, 
+                [out] UINT * pVarIndex
+            );
+
+    HRESULT GetCustData(
+                [in] REFGUID guid,
+                [out] VARIANT * pVarVal
+            );
+    
+    HRESULT GetFuncCustData(
+                [in] UINT index, 
+                [in] REFGUID guid, 
+                [out] VARIANT * pVarVal
+            );
+    
+    HRESULT GetParamCustData(
+                [in] UINT indexFunc, 
+                [in] UINT indexParam, 
+                [in] REFGUID guid, 
+                [out] VARIANT * pVarVal
+            );
+
+    HRESULT GetVarCustData(
+                [in] UINT index, 
+                [in] REFGUID guid, 
+                [out] VARIANT * pVarVal
+            );
+
+    HRESULT GetImplTypeCustData(
+                [in] UINT index, 
+                [in] REFGUID guid, 
+                [out] VARIANT * pVarVal
+            );
+
+    [local]
+    HRESULT GetDocumentation2(
+                [in] MEMBERID memid,
+                [in] LCID lcid,
+                [out] BSTR *pbstrHelpString,
+                [out] DWORD *pdwHelpStringContext,
+                [out] BSTR *pbstrHelpStringDll
+            );
+
+    [call_as(GetDocumentation2)]
+    HRESULT RemoteGetDocumentation2(
+                [in] MEMBERID memid,
+                [in] LCID lcid,
+                [in] DWORD refPtrFlags,
+                [out] BSTR *pbstrHelpString,
+                [out] DWORD *pdwHelpStringContext,
+                [out] BSTR *pbstrHelpStringDll
+            );
+
+    HRESULT GetAllCustData(
+                [out] CUSTDATA * pCustData
+            );
+    
+    HRESULT GetAllFuncCustData(
+                [in] UINT index, 
+                [out] CUSTDATA * pCustData
+            );
+    
+    HRESULT GetAllParamCustData(
+                [in] UINT indexFunc, 
+                [in] UINT indexParam, 
+                [out] CUSTDATA * pCustData
+            );
+
+    HRESULT GetAllVarCustData(
+                [in] UINT index, 
+                [out] CUSTDATA * pCustData
+            );
+
+    HRESULT GetAllImplTypeCustData(
+                [in] UINT index, 
+                [out] CUSTDATA * pCustData
+            );
+}
+
+
+[
+    object,
+    uuid(00020402-0000-0000-C000-000000000046),
+    pointer_default(unique)
+]
+
+interface ITypeLib : IUnknown
+{
+    typedef [v1_enum] enum tagSYSKIND {
+        SYS_WIN16 = 0,
+        SYS_WIN32,
+        SYS_MAC
+    } SYSKIND;
+
+    typedef [v1_enum] enum tagLIBFLAGS {
+        LIBFLAG_FRESTRICTED = 0x01,
+        LIBFLAG_FCONTROL = 0x02,
+        LIBFLAG_FHIDDEN = 0x04,
+        LIBFLAG_FHASDISKIMAGE = 0x08
+    } LIBFLAGS;
+
+    typedef [unique] ITypeLib * LPTYPELIB;
+
+    
+    typedef [nofree]struct tagTLIBATTR {
+        GUID guid;
+        LCID lcid;
+        SYSKIND syskind;
+        WORD wMajorVerNum;
+        WORD wMinorVerNum;
+        WORD wLibFlags;
+    } TLIBATTR, * LPTLIBATTR;
+
+    [local]
+    UINT GetTypeInfoCount(
+                void
+            );
+
+    [call_as(GetTypeInfoCount)]
+    HRESULT RemoteGetTypeInfoCount(
+                [out]  UINT * pcTInfo
+            );
+
+    HRESULT GetTypeInfo(
+                [in]  UINT index,
+                [out] ITypeInfo ** ppTInfo
+            );
+
+    HRESULT GetTypeInfoType(
+                [in]  UINT index,
+                [out] TYPEKIND * pTKind
+            );
+
+    HRESULT GetTypeInfoOfGuid(
+                [in]  REFGUID guid,
+                [out] ITypeInfo ** ppTinfo
+            );
+
+    [local]
+    HRESULT GetLibAttr(
+                [out] TLIBATTR ** ppTLibAttr
+            );
+
+    [call_as(GetLibAttr)]
+    HRESULT RemoteGetLibAttr(
+                [out] LPTLIBATTR * ppTLibAttr,
+                [out] CLEANLOCALSTORAGE * pDummy
+            );
+
+    HRESULT GetTypeComp(
+                [out] ITypeComp ** ppTComp
+            );
+
+    [local]
+    HRESULT GetDocumentation(
+                [in]  INT index,
+                [out] BSTR * pBstrName,
+                [out] BSTR * pBstrDocString,
+                [out] DWORD * pdwHelpContext,
+                [out] BSTR * pBstrHelpFile
+            );
+
+    [call_as(GetDocumentation)]
+    HRESULT RemoteGetDocumentation(
+                [in]  INT index,
+                [in]  DWORD refPtrFlags,
+                [out] BSTR * pBstrName,
+                [out] BSTR * pBstrDocString,
+                [out] DWORD * pdwHelpContext,
+                [out] BSTR * pBstrHelpFile
+            );
+
+    [local]
+    HRESULT IsName(
+                [in, out] LPOLESTR szNameBuf,
+                [in] ULONG lHashVal,
+                [out] BOOL * pfName
+            );
+
+    [call_as(IsName)]
+    HRESULT RemoteIsName(
+                [in] LPOLESTR szNameBuf,
+                [in] ULONG lHashVal,
+                [out] BOOL * pfName,
+                [out] BSTR * pBstrLibName
+            );
+
+    [local]
+    HRESULT FindName(
+                [in, out] LPOLESTR szNameBuf,
+                [in] ULONG lHashVal,
+                [out,size_is(*pcFound),length_is(*pcFound)] ITypeInfo **ppTInfo,
+                [out,size_is(*pcFound),length_is(*pcFound)] MEMBERID * rgMemId,
+                [in, out] USHORT * pcFound
+            );
+
+    [call_as(FindName)]
+    HRESULT RemoteFindName(
+                [in] LPOLESTR szNameBuf,
+                [in] ULONG lHashVal,
+                [out,size_is(*pcFound),length_is(*pcFound)] ITypeInfo **ppTInfo,
+                [out,size_is(*pcFound),length_is(*pcFound)] MEMBERID * rgMemId,
+                [in, out] USHORT * pcFound,
+                [out] BSTR * pBstrLibName
+            );
+
+    [local]
+    void ReleaseTLibAttr(
+                [in,ptr]  TLIBATTR * pTLibAttr
+            );
+
+    [call_as(ReleaseTLibAttr)]
+    HRESULT LocalReleaseTLibAttr(
+                void
+            );
+}
+
+
+[
+    object,
+    uuid(00020411-0000-0000-C000-000000000046),
+    pointer_default(unique)
+]
+
+interface ITypeLib2 : ITypeLib
+{
+    typedef [unique] ITypeLib2 * LPTYPELIB2;
+
+    HRESULT GetCustData(
+                [in] GUID* guid,
+                [out] VARIANT * pVarVal
+            );
+
+    [local]
+    HRESULT GetLibStatistics(
+                [out] ULONG * pcUniqueNames,
+                [out] ULONG * pcchUniqueNames
+            );
+
+    [call_as(GetLibStatistics)]
+    HRESULT RemoteGetLibStatistics(
+                [out] ULONG * pcUniqueNames,
+                [out] ULONG * pcchUniqueNames
+            );
+
+    [local]
+    HRESULT GetDocumentation2(
+                [in]  INT index,
+                [in]  LCID lcid,
+                [out] BSTR *pbstrHelpString,
+                [out] DWORD *pdwHelpStringContext,
+                [out] BSTR *pbstrHelpStringDll
+            );
+
+    [call_as(GetDocumentation2)]
+    HRESULT RemoteGetDocumentation2(
+                [in]  INT index,
+                [in]  LCID lcid,
+                [in]  DWORD refPtrFlags,
+                [out] BSTR *pbstrHelpString,
+                [out] DWORD *pdwHelpStringContext,
+                [out] BSTR *pbstrHelpStringDll
+            );
+
+
+    HRESULT GetAllCustData(
+                [out] CUSTDATA * pCustData
+            );
+}
+
+
+[
+    object,
+    uuid(00020410-0000-0000-C000-000000000046),
+    pointer_default(unique),
+    local
+]
+
+interface ITypeChangeEvents: IUnknown
+{
+    typedef [unique] ITypeChangeEvents * LPTYPECHANGEEVENTS;
+
+    // notification messages used by the dynamic typeinfo protocol.
+    typedef enum tagCHANGEKIND {
+        CHANGEKIND_ADDMEMBER,
+        CHANGEKIND_DELETEMEMBER,
+        CHANGEKIND_SETNAMES,
+        CHANGEKIND_SETDOCUMENTATION,
+        CHANGEKIND_GENERAL,
+        CHANGEKIND_INVALIDATE,
+        CHANGEKIND_CHANGEFAILED,
+        CHANGEKIND_MAX
+    } CHANGEKIND;
+
+    HRESULT RequestTypeChange(
+                [in] CHANGEKIND changeKind,
+                [in] ITypeInfo * pTInfoBefore,
+                [in] LPOLESTR pStrName,
+                [out] INT * pfCancel
+            );
+    
+    HRESULT AfterTypeChange(
+                [in] CHANGEKIND changeKind,
+                [in] ITypeInfo * pTInfoAfter,
+                [in] LPOLESTR pStrName
+            );
+}
+
+};
+ comlib/WideString.hs view
@@ -0,0 +1,153 @@+{-# OPTIONS -#include <stdlib.h> #-}
+{-# OPTIONS -#include "WideStringSrc.h" #-}
+{-# OPTIONS -#include "PointerSrc.h" #-}
+-- Automatically generated by HaskellDirect (ihc.exe), version 0.20
+-- Created: 20:10 Pacific Standard Time, Tuesday 16 December, 2003
+-- Command line: -fno-qualified-names -fno-imports -fno-export-lists -fkeep-hresult -fout-pointers-are-not-refs -c WideString.idl -o WideString.hs
+
+module WideString where
+
+
+
+import PointerPrim
+import Pointer
+import Foreign.Ptr
+import HDirect
+import Word         ( Word32 )
+import Int
+import IOExts
+
+type LPWSTR = WideString
+type LPCWSTR = WideString
+
+newtype WideString = WideString (Ptr Wchar_t)
+
+lengthWideString :: WideString -> Int
+lengthWideString (WideString ws) = unsafePerformIO (lenWideString ws >>= return . fromIntegral)
+
+stackWideString :: String -> (Ptr Wchar_t -> IO a) -> IO a
+stackWideString str wcont = do
+    stackString str $ \ len pstr -> do
+    let wlen = wideStringLen pstr
+    stackFrame (sizeofWideString*(wlen+1)) $ \ pwide -> do
+    primStringToWide pstr (fromIntegral len) pwide wlen 
+    wcont pwide
+
+mkWideString :: String -> WideString
+mkWideString ls = unsafePerformIO (stringToWide ls)
+
+stringToWide :: String -> IO WideString
+stringToWide str =
+  stackString str $ \ len pstr -> do
+  let wlen = wideStringLen pstr
+   -- Note: we're using the task allocator here.
+  pwide <- primAllocMemory ((wlen + 1) * sizeofWideString)
+  primStringToWide pstr (fromIntegral len) (castPtr pwide) wlen
+  unmarshallWideString (castPtr pwide)
+
+-- Sometimes a (wchar_t*) double up as holding a 16-bit (yep, no kidding) -
+-- higher 16 bits have to be zero, lower 16 the val. We *love* this stuff.
+word16ToWideString :: Word16 -> IO WideString
+word16ToWideString w = 
+  return (WideString (plusPtr nullPtr (fromIntegral w)))
+
+nullWideString :: WideString
+nullWideString = WideString (nullPtr)
+
+-- Does not belong here - at all.
+
+stackString :: String -> (Int -> Ptr Char -> IO a) -> IO a
+stackString str pcont = do
+   let len = 1 + fromIntegral (length str)
+   stackFrame len $ \ ptr -> do
+   writeString False ptr str
+   pcont (fromIntegral len) (castPtr ptr)
+
+marshallWideString :: WideString -> IO (Ptr WideString)
+marshallWideString (WideString ptr) = marshallPointer ptr >>= return.castPtr
+
+marshallWideString2 :: String -> IO (Ptr WideString)
+marshallWideString2 str = do
+  wstr <- stringToWide str
+  marshallWideString wstr
+
+-- using 'Ptr a' is too weak, really - but avoids trivial
+-- problems wrt WideString/Wchar_t confusion. ToDo: tidy up.
+unmarshallWideString :: Ptr a -> IO WideString
+unmarshallWideString ptr = do
+  po <- unmarshallPointer ptr
+  return (WideString (castPtr po))
+
+unmarshallWideString2 :: Ptr a -> IO String
+unmarshallWideString2 ptr = do
+  po <- unmarshallPointer ptr
+  wideToStr (WideString (castPtr po))
+
+-- writeWideString doesn't copy the wide string, it merely
+-- fills in a pointer to the wide string.
+
+writeWideString :: Ptr WideString -> WideString -> IO ()
+writeWideString ptr (WideString pstr) = writePointer (castPtr ptr) pstr
+
+writeWideString2 :: Ptr WideString -> String -> IO ()
+writeWideString2 ptr str = do
+   pwstr <- marshallWideString2 str
+   writePointer (castPtr ptr) pwstr
+
+-- is this correct?
+readWideString :: Ptr WideString -> IO WideString
+readWideString p = unmarshallWideString (castPtr p)
+
+readWideString2 :: Ptr WideString -> IO String
+readWideString2 p = unmarshallWideString2 (castPtr p)
+
+freeWideString :: Ptr WideString -> IO ()
+freeWideString _ = return () --(WideString pstr) = freeMemory pstr
+
+freeWString :: WideString -> IO ()
+freeWString (WideString pstr) = freeMemory pstr
+
+sizeofWideString :: Word32
+sizeofWideString = 2  -- not set in stone.
+
+wideToStr :: WideString -> IO String
+wideToStr wide = do
+   pwide     <- marshallWideString wide
+   (pstr,hr) <- wideToString (castPtr pwide)
+   unmarshallString (castPtr pstr)
+
+
+wideStringLen :: Ptr Char
+              -> Word32
+wideStringLen str =
+  unsafePerformIO (prim_WideString_wideStringLen str)
+
+foreign import stdcall "wideStringLen" prim_WideString_wideStringLen :: Ptr Char -> IO Word32
+wideToString :: Ptr Wchar_t
+             -> IO (Ptr Char, Int32)
+wideToString wstr =
+  do
+    pstr <- allocBytes (fromIntegral sizeofPtr)
+    o_wideToString <- prim_WideString_wideToString wstr pstr
+    pstr <- doThenFree free readPtr pstr
+    return (pstr, o_wideToString)
+
+foreign import stdcall "wideToString" prim_WideString_wideToString :: Ptr Word16 -> Ptr (Ptr Char) -> IO Int32
+lenWideString :: Ptr Wchar_t
+              -> IO Int32
+lenWideString wstr = prim_WideString_lenWideString wstr
+
+foreign import stdcall "lenWideString" prim_WideString_lenWideString :: Ptr Word16 -> IO Int32
+primStringToWide :: Ptr Char
+                 -> Word32
+                 -> Ptr Wchar_t
+                 -> Word32
+                 -> IO Int32
+primStringToWide str len wstr wlen =
+  prim_WideString_primStringToWide str
+                                   len
+                                   wstr
+                                   wlen
+
+foreign import stdcall "primStringToWide" prim_WideString_primStringToWide :: Ptr Char -> Word32 -> Ptr Word16 -> Word32 -> IO Int32
+
+ comlib/WideString.idl view
@@ -0,0 +1,131 @@+stub_include <stdlib.h>;
+stub_include("WideStringSrc.h");
+stub_include("PointerSrc.h");
+[pointer_default(ptr)]
+module WideString {
+
+
+hs_quote("
+import PointerPrim
+import Pointer
+import Foreign.Ptr
+import HDirect
+import Word         ( Word32 )
+import Int
+import IOExts
+
+type LPWSTR = WideString
+type LPCWSTR = WideString
+
+newtype WideString = WideString (Ptr Wchar_t)
+
+lengthWideString :: WideString -> Int
+lengthWideString (WideString ws) = unsafePerformIO (lenWideString ws >>= return . fromIntegral)
+
+stackWideString :: String -> (Ptr Wchar_t -> IO a) -> IO a
+stackWideString str wcont = do
+    stackString str $ \ len pstr -> do
+    let wlen = wideStringLen pstr
+    stackFrame (sizeofWideString*(wlen+1)) $ \ pwide -> do
+    primStringToWide pstr (fromIntegral len) pwide wlen 
+    wcont pwide
+
+mkWideString :: String -> WideString
+mkWideString ls = unsafePerformIO (stringToWide ls)
+
+stringToWide :: String -> IO WideString
+stringToWide str =
+  stackString str $ \ len pstr -> do
+  let wlen = wideStringLen pstr
+   -- Note: we're using the task allocator here.
+  pwide <- primAllocMemory ((wlen + 1) * sizeofWideString)
+  primStringToWide pstr (fromIntegral len) (castPtr pwide) wlen
+  unmarshallWideString (castPtr pwide)
+
+-- Sometimes a (wchar_t*) double up as holding a 16-bit (yep, no kidding) -
+-- higher 16 bits have to be zero, lower 16 the val. We *love* this stuff.
+word16ToWideString :: Word16 -> IO WideString
+word16ToWideString w = 
+  return (WideString (plusPtr nullPtr (fromIntegral w)))
+
+nullWideString :: WideString
+nullWideString = WideString (nullPtr)
+
+-- Does not belong here - at all.
+
+stackString :: String -> (Int -> Ptr Char -> IO a) -> IO a
+stackString str pcont = do
+   let len = 1 + fromIntegral (length str)
+   stackFrame len $ \ ptr -> do
+   writeString False ptr str
+   pcont (fromIntegral len) (castPtr ptr)
+
+marshallWideString :: WideString -> IO (Ptr WideString)
+marshallWideString (WideString ptr) = marshallPointer ptr >>= return.castPtr
+
+marshallWideString2 :: String -> IO (Ptr WideString)
+marshallWideString2 str = do
+  wstr <- stringToWide str
+  marshallWideString wstr
+
+-- using 'Ptr a' is too weak, really - but avoids trivial
+-- problems wrt WideString/Wchar_t confusion. ToDo: tidy up.
+unmarshallWideString :: Ptr a -> IO WideString
+unmarshallWideString ptr = do
+  po <- unmarshallPointer ptr
+  return (WideString (castPtr po))
+
+unmarshallWideString2 :: Ptr a -> IO String
+unmarshallWideString2 ptr = do
+  po <- unmarshallPointer ptr
+  wideToStr (WideString (castPtr po))
+
+-- writeWideString doesn't copy the wide string, it merely
+-- fills in a pointer to the wide string.
+
+writeWideString :: Ptr WideString -> WideString -> IO ()
+writeWideString ptr (WideString pstr) = writePointer (castPtr ptr) pstr
+
+writeWideString2 :: Ptr WideString -> String -> IO ()
+writeWideString2 ptr str = do
+   pwstr <- marshallWideString2 str
+   writePointer (castPtr ptr) pwstr
+
+-- is this correct?
+readWideString :: Ptr WideString -> IO WideString
+readWideString p = unmarshallWideString (castPtr p)
+
+readWideString2 :: Ptr WideString -> IO String
+readWideString2 p = unmarshallWideString2 (castPtr p)
+
+freeWideString :: Ptr WideString -> IO ()
+freeWideString _ = return () --(WideString pstr) = freeMemory pstr
+
+freeWString :: WideString -> IO ()
+freeWString (WideString pstr) = freeMemory pstr
+
+sizeofWideString :: Word32
+sizeofWideString = 2  -- not set in stone.
+
+wideToStr :: WideString -> IO String
+wideToStr wide = do
+   pwide     <- marshallWideString wide
+   (pstr,hr) <- wideToString (castPtr pwide)
+   unmarshallString (castPtr pstr)
+
+");
+
+[pure]
+unsigned int wideStringLen([in,ptr]char* str);
+int wideToString ( [in,ptr]wchar_t* wstr
+		 , [out,ref]char** pstr
+		 );
+int lenWideString ( [in,ptr]wchar_t* wstr );
+
+int primStringToWide( [in,ptr]char* str
+		    , [in]unsigned int len
+		    , [in,ptr]wchar_t* wstr
+		    , [in]unsigned int wlen
+		    );
+
+};
+ comlib/WideStringSrc.c view
@@ -0,0 +1,177 @@+/* define the DLL export macro */
+#if defined(_WIN32) && !defined(__CYGWIN32__)
+#define DLLEXPORT(res)  __declspec(dllexport) res
+#else
+/* redef this default for your system */
+#define DLLEXPORT(res)  extern res
+#endif
+
+
+#ifdef COM
+#define COBJMACROS
+#define CINTERFACE
+#endif
+
+#include <stdio.h>
+
+#if defined(_WIN32) && !defined(__CYGWIN32__)
+#include <windows.h>
+#define WCHAR wchar_t
+#else
+ #ifdef __CYGWIN32__
+  #include <windows.h>
+ #endif
+#include <stdlib.h>
+#define WCHAR wchar_t
+#endif
+
+#include "WideStringSrc.h"
+
+#ifdef COM
+#include "comPrim.h"
+#else
+#define UNI2STR(regstr, unistr) wcstombs (regstr, unistr, wcslen (unistr)+1)
+#endif
+
+/* wcslen() substitute implementation for cygwin'ers. */
+#if defined(__CYGWIN32__) || defined(__CYGWIN__)
+
+/* Troublesome to use the one that comes with 20.1 of cygwin */
+#ifdef MB_CUR_MAX
+#undef MB_CUR_MAX
+#endif
+#define MB_CUR_MAX 2
+
+static int wcslen(WCHAR* wstr)
+{
+  char str[MB_CUR_MAX];
+  char msg[80];
+  WCHAR* wptr;
+  int nbytes, i = 0;
+  
+  wptr = wstr;
+
+  if ( wptr == NULL )
+     return 0;
+
+  while ( *wptr != L'\0' ) {
+     nbytes = wctomb ( str, *wptr );
+     i += nbytes; (char*)wptr += nbytes;
+  }
+  return i;
+}
+#endif
+
+
+/* Return the length of a wide string big enough
+   to hold the multi-byte string.
+*/
+unsigned int wideStringLen (char* str)
+{
+#ifdef _WIN32
+  return MultiByteToWideChar(CP_ACP, 0, str, -1, NULL, 0);
+#else
+  /* Non Win32 specific version */
+  WCHAR foo[300];  // Ho-ho, bulletproof!
+  unsigned int len;
+
+  if (!str) {
+     return 0;
+  } else {
+     len = mbstowcs (foo, str, strlen(str));
+     return ( (len < 0) ? 0 : len);
+  }
+#endif
+}
+
+/* ToDo: sort out source code deps. and make
+   the return type HRESULT.
+*/
+int
+wideToString ( WCHAR* wstr, char** pstr )
+{
+  int len;
+  char* str;
+
+  if (!pstr) {
+#ifdef _WIN32
+    return E_FAIL;
+#else
+    return -1;
+#endif
+  }
+
+#if defined(_WIN32) && defined(COM)
+
+  /* Compute how big a buffer we need to allocate for
+     multi-byte string...
+  */
+  len = WideCharToMultiByte ( CP_ACP, 0, wstr, -1
+			    , NULL, 0, NULL, NULL);
+  if (len == 0) {
+    return E_FAIL;
+  }
+
+  /* 
+    Ask COM task allocator for some memory.
+   */
+  str = CoTaskMemAlloc(len * sizeof(char));
+  if (str == NULL) {
+    return E_FAIL;
+  }
+
+  WideCharToMultiByte(CP_ACP, 0, wstr, -1, str, len, NULL, NULL);
+  *pstr = str;
+  return S_OK;
+
+#else
+
+  len = wcslen(wstr);
+  str=(char*)malloc(len+1);
+  UNI2STR(str,wstr);
+  *pstr = str;
+  return 0;
+
+#endif
+}
+
+/* Converting (null-terminated) strings into wide/Unicode ones */
+int primStringToWide( char* str, unsigned int len, WCHAR* wstr , unsigned int wlen )
+{
+#ifdef _WIN32
+  return MultiByteToWideChar(CP_ACP, 0, str, len, wstr, wlen);
+#else
+  int l;
+
+  if ( wstr ) {
+    if ( !str ) {
+       *wstr = 0;
+       return 0;
+    } else {
+       l = mbstowcs (wstr, str, wlen+1);
+       return l;
+    }
+ } else {
+    return (-1);
+ }
+#endif
+}
+
+/* The proto might not be in scope, so you might
+   just get a warning from the C compiler.
+   
+   Reluctant to define the proto, as experience has
+   shown this to be troublesome (there appears to be no
+   universal agreement as to what the return type of
+   wcslen() is.)
+
+extern int wcslen (const WCHAR* wstr);
+extern size_t wcslen (const WCHAR* wstr);
+
+*/  
+
+int
+lenWideString (WCHAR* wstr )
+{
+  return wcslen(wstr);
+}
+ comlib/autoPrim.h view
@@ -0,0 +1,321 @@+/*
+ To free ourselves from a couple of needless compiler/
+ header file dependencies, we provide a hand-written
+ set of definitions for Automation related types
+ and interfaces.
+*/
+#ifndef __AUTOPRIM_H__
+#define __AUTOPRIM_H__
+
+#include "comPrim.h"
+#include "PointerSrc.h"
+
+#if (defined(__CYGWIN32__) || defined(__MINGW32__)) && __W32API_MAJOR_VERSION == 1
+typedef LONG DISPID;
+#define DISPATCH_METHOD         0x1
+#define DISPATCH_PROPERTYGET    0x2
+#define DISPATCH_PROPERTYPUT    0x4
+#define DISPATCH_PROPERTYPUTREF 0x8
+
+#define	DISPID_VALUE	         (0)
+#define	DISPID_UNKNOWN	        (-1)
+#define	DISPID_PROPERTYPUT	(-3)
+#define	DISPID_NEWENUM	        (-4)
+#define	DISPID_EVALUATE	        (-5)
+#define	DISPID_CONSTRUCTOR	(-6)
+#define	DISPID_DESTRUCTOR	(-7)
+
+typedef LONG SCODE;
+
+enum VARENUM
+    {	VT_EMPTY	= 0,
+	VT_NULL	= 1,
+	VT_I2	= 2,
+	VT_I4	= 3,
+	VT_R4	= 4,
+	VT_R8	= 5,
+	VT_CY	= 6,
+	VT_DATE	= 7,
+	VT_BSTR	= 8,
+	VT_DISPATCH	= 9,
+	VT_ERROR	= 10,
+	VT_BOOL	= 11,
+	VT_VARIANT	= 12,
+	VT_UNKNOWN	= 13,
+	VT_DECIMAL	= 14,
+	VT_I1	= 16,
+	VT_UI1	= 17,
+	VT_UI2	= 18,
+	VT_UI4	= 19,
+	VT_I8	= 20,
+	VT_UI8	= 21,
+	VT_INT	= 22,
+	VT_UINT	= 23,
+	VT_VOID	= 24,
+	VT_HRESULT	= 25,
+	VT_PTR	= 26,
+	VT_SAFEARRAY	= 27,
+	VT_CARRAY	= 28,
+	VT_USERDEFINED	= 29,
+	VT_LPSTR	= 30,
+	VT_LPWSTR	= 31,
+	VT_FILETIME	= 64,
+	VT_BLOB	= 65,
+	VT_STREAM	= 66,
+	VT_STORAGE	= 67,
+	VT_STREAMED_OBJECT	= 68,
+	VT_STORED_OBJECT	= 69,
+	VT_BLOB_OBJECT	= 70,
+	VT_CF	= 71,
+	VT_CLSID	= 72,
+	VT_BSTR_BLOB	= 0xfff,
+	VT_VECTOR	= 0x1000,
+	VT_ARRAY	= 0x2000,
+	VT_BYREF	= 0x4000,
+	VT_RESERVED	= 0x8000,
+	VT_ILLEGAL	= 0xffff,
+	VT_ILLEGALMASKED	= 0xfff,
+	VT_TYPEMASK	= 0xfff
+    };
+
+typedef struct ITypeInfo ITypeInfo;
+
+typedef struct tagEXCEPINFO 
+{
+  unsigned short wCode;
+  unsigned short wReserved;
+  BSTR bstrSource;
+  BSTR bstrDescription;
+  BSTR bstrHelpFile;
+  unsigned long dwHelpContext;
+  void* pvReserved;
+  HRESULT (STDCALL *pfnDeferredFillIn) (struct tagEXCEPINFO*);
+  SCODE scode;
+} EXCEPINFO;
+
+typedef unsigned short VARTYPE;
+typedef short VARIANT_BOOL;
+typedef VARIANT_BOOL _VARIANT_BOOL;
+typedef double DATE;
+
+#if 0
+typedef unsigned long long ULONGLONG;
+#endif
+
+typedef struct tagCY {
+    unsigned long Lo;
+    long      Hi;
+} CY;
+
+typedef struct IDispatch IDispatch;
+
+typedef struct tagDEC {
+    USHORT wReserved;
+    BYTE  scale;
+    BYTE  sign;
+    ULONG Hi32;
+    unsigned long long Lo64;
+} DECIMAL;
+
+typedef struct tagSAFEARRAY SAFEARRAY;
+
+typedef struct tagVARIANT VARIANT;
+
+struct tagVARIANT 
+{
+  union {
+   struct __tagVARIANT {
+    VARTYPE vt;
+    WORD wReserved1;
+    WORD wReserved2;
+    WORD wReserved3;
+    union {
+      LONG           lVal;
+      BYTE           bVal;
+      SHORT          iVal;
+      FLOAT          fltVal;
+      double         dblVal;
+      VARIANT_BOOL   boolVal;
+      _VARIANT_BOOL  bool;
+      SCODE          scode;
+      CY             cyVal;
+      DATE           date;
+      BSTR           bstrVal;
+      IUnknown*      punkVal;
+      IDispatch*     pdispVal;
+      SAFEARRAY*     parray;
+      BYTE*          pbVal;
+      SHORT*         piVal;
+      LONG*          plVal;
+      FLOAT*         pfltVal;
+      double*        pdblVal;
+      VARIANT_BOOL*  pboolVal;
+      _VARIANT_BOOL* pbool;
+      SCODE*      pscode;
+      CY*         pcyVal;
+      DATE*       pdate;
+      BSTR*       pbstrVal;
+      IUnknown**  ppunkVal;
+      IDispatch** ppdispVal;
+      SAFEARRAY** pparray;
+      VARIANT*    pvarVal;
+      PVOID       byref;
+      CHAR        cVal;
+      USHORT      uiVal;
+      ULONG       ulVal;
+      INT         intVal;
+      UINT        uintVal;
+      DECIMAL*    pdecVal;
+      CHAR*       pcVal;
+      USHORT*     puiVal;
+      ULONG*      pulVal;
+      INT*        pintVal;
+      UINT*       puintVal;
+      } n3;
+   } n2;
+   DECIMAL decVal;
+  } n1;
+};
+
+typedef VARIANT VARIANTARG;
+
+
+typedef struct tagDISPPARAMS 
+{
+  VARIANTARG*  rgvarg;
+  DISPID*      rgdispidNamedArgs;
+  unsigned int cArgs;
+  unsigned int cNamedArgs;
+} DISPPARAMS;
+
+typedef struct IDispatchVtbl
+    {
+        HRESULT ( STDCALL  *QueryInterface )
+	   		( IDispatch  * This
+			, REFIID riid
+			, void  **ppvObject
+			);
+        
+        ULONG ( STDCALL  *AddRef )( IDispatch  * This );
+        
+        ULONG ( STDCALL  *Release )( IDispatch  * This );
+        
+        HRESULT ( STDCALL  *GetTypeInfoCount )
+			( IDispatch  * This
+			, UINT  *pctinfo
+			);
+        
+        HRESULT ( STDCALL *GetTypeInfo )
+	                ( IDispatch  *This
+			, UINT iTInfo
+			, LCID lcid
+			,ITypeInfo  **ppTInfo
+			);
+        
+        HRESULT ( STDCALL  *GetIDsOfNames )
+	                ( IDispatch  *This
+			, REFIID riid
+			, LPOLESTR  *rgszNames
+			, UINT cNames
+			, LCID lcid
+			, DISPID  *rgDispId
+			);
+        
+        HRESULT ( STDCALL  *Invoke )
+	                ( IDispatch  *This
+			, DISPID dispIdMember
+			, REFIID riid
+			, LCID lcid
+			, WORD wFlags
+			, DISPPARAMS  *pDispParams
+			, VARIANT  *pVarResult
+			, EXCEPINFO  *pExcepInfo
+			,UINT  *puArgErr
+			);
+
+    } IDispatchVtbl;
+
+struct IDispatch { struct IDispatchVtbl *lpVtbl; };
+#endif
+
+
+#define IDispatch_GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId)	\
+    (This)->lpVtbl -> GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId)
+
+#define IDispatch_Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr)	\
+    (This)->lpVtbl -> Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr)
+
+#if __W32API_MAJOR_VERSION == 1
+extern void STDCALL VariantInit(VARIANTARG* pvarg);
+extern HRESULT STDCALL VariantClear(VARIANTARG* pvarg);
+extern HRESULT STDCALL VariantCopy(VARIANTARG* pvArgDest, VARIANTARG* pvArgSrc);
+extern HRESULT STDCALL VariantChangeType( VARIANTARG* pvargDest
+				, VARIANTARG* pvarSrc
+				, unsigned short wFlags
+				, VARTYPE vt
+				);
+#endif
+
+extern int dispErrorUNKNOWNNAME(HRESULT hr);
+extern int dispErrorEXCEPTION(HRESULT hr);
+extern HRESULT readVarVariant( VARIANT* v, VARIANT* x );
+extern int readVariantTag( VARIANT* v );
+extern void writeVarVariant( VARIANT* x, VARIANT* v);
+extern HRESULT readVarCurrency( VARIANT* v, int* hi, int* lo );
+extern void writeVarCurrency( int hi, unsigned int lo, VARIANT* v );
+extern HRESULT readVarWord64( VARIANT* v, unsigned int* hi, unsigned int* lo );
+extern void writeVarWord64( unsigned int hi, unsigned int lo, VARIANT* v );
+extern HRESULT readVarNull( VARIANT* v );
+extern void writeVarNull( VARIANT* v );
+extern void writeVarEmpty( VARIANT* v );
+extern void writeVarOptional( VARIANT* v );
+extern void writeVarSAFEARRAY ( VARIANT* v, SAFEARRAY* sa, VARTYPE vt);
+extern HRESULT readVarSAFEARRAY  ( VARIANT* v, SAFEARRAY** sa, VARTYPE vt);
+
+#define READWRITEPROTO(htype,ctype) \
+extern void writeVar##htype( ctype x, VARIANT* v); \
+extern HRESULT readVar##htype( VARIANT* v, ctype* p)
+
+#define READWRITETEMPPROTO(htype,ctype) \
+extern void writeVar##htype( ctype x, VARIANT* v); \
+extern HRESULT readVar##htype( VARIANT* v, ctype* p, VARIANT** w)
+
+READWRITEPROTO(Short,int);
+READWRITEPROTO(Int,int);
+READWRITEPROTO(Word,unsigned int);
+READWRITEPROTO(Float,float);
+READWRITEPROTO(Double, double);
+READWRITEPROTO(Date, double);
+READWRITETEMPPROTO(String, BSTR);
+READWRITETEMPPROTO(Dispatch, IDispatch*);
+READWRITEPROTO(Bool, BOOL);
+READWRITETEMPPROTO(Unknown, IUnknown*);
+READWRITEPROTO(Byte, unsigned char);
+READWRITEPROTO(Error, int);
+
+extern void freeVariants( int count, VARIANT* p );
+extern HRESULT 
+dispatchGetMemberID( IDispatch* obj, BSTR name, LCID lcid, DISPID* dispid );
+extern char* getExcepInfoMessage( EXCEPINFO* info );
+extern void freeExcepInfo( EXCEPINFO* info );
+extern HRESULT 
+dispatchInvoke( IDispatch* obj, DISPID dispid, LCID lcid,
+                BOOL isfunction, unsigned flags,
+                int cargs, int cargsout,
+                VARIANT* args, VARIANT* argsout,
+                EXCEPINFO** info );
+
+extern
+HRESULT
+STDCALL
+SafeArrayDestroy
+ 	( /*[in]*/SAFEARRAY* psa 
+	);
+
+extern HRESULT primCopyVARIANT  ( VARIANT* p1, VARIANT* p2 );
+extern HRESULT primVARIANTClear ( VARIANT* p1 );
+
+extern HRESULT primClockToDate (/*[in]*/int ct, /*[out]*/double* pT);
+
+#endif /* __AUTOPRIM_H__ */
+
+ comlib/com.pkg view
@@ -0,0 +1,13 @@+Package{ name = "com",
+	 import_dirs  = ["${hd_libdir}"],
+	 source_dirs  = [],
+	 library_dirs = ["${hd_libdir}"],
+	 hs_libraries = ["HScom"],
+	 extra_libraries = ["kernel32", "user32", "ole32", "oleaut32", "advapi32"],
+	 include_dirs = ["${hd_libdir}"],
+	 c_includes   = [],
+	 package_deps = ["base", "haskell98", "lang"],
+	 extra_ghc_opts = [],
+	 extra_cc_opts  = [],
+	 extra_ld_opts  = []}
+
+ comlib/comPrim.h view
@@ -0,0 +1,651 @@+/*
+ To free ourselves from a couple of needless compiler/
+ header file dependencies, we provide a hand-written
+ set of definitions for IUnknown.
+*/
+#ifndef __COMPRIM_H__
+#define __COMPRIM_H__
+
+#define COBJMACROS
+#include <windows.h>
+
+#if defined(__MINGW32__) || defined(__CYGWIN32__)
+/* Get at w32api version; assume both mingw and cygwin use it. */
+#include <w32api.h>
+#endif
+
+#ifndef REFIID
+typedef GUID IID;
+#define REFIID const IID *
+#endif
+
+#ifndef REFCLSID
+#define REFCLSID const CLSID *
+#endif
+
+#define FACILITY_WIN32                   7
+#ifndef HRESULT_FROM_WIN32
+#define HRESULT_FROM_WIN32(x)   (x ? ((HRESULT) (((x) & 0x0000FFFF) | (FACILITY_WIN32 << 16) | 0x80000000)) : 0 )
+#endif
+
+#ifndef SUCCEEDED
+#define SUCCEEDED(hr)  ((hr) >= 0)
+#endif
+
+#if __W32API_MAJOR_VERSION == 1
+typedef WCHAR OLECHAR;
+typedef OLECHAR* LPOLESTR;
+typedef const OLECHAR* LPCOLESTR;
+
+typedef WCHAR* BSTR;
+#endif
+
+extern const IID IID_NULL;
+extern const IID IID_IUnknown;
+extern const IID IID_IClassFactory;
+
+#if __W32API_MAJOR_VERSION == 1
+typedef struct IUnknown IUnknown;
+
+typedef struct IUnknownVtbl {
+      HRESULT (STDCALL *QueryInterface) 
+                           ( IUnknown* This
+                           , REFIID riid
+                           , void** ppvObject
+                           );
+      ULONG   (STDCALL *AddRef)  ( IUnknown* This );
+      ULONG   (STDCALL *Release) ( IUnknown* This );
+} IUnknownVtbl;
+
+struct IUnknown { struct IUnknownVtbl* lpVtbl;};
+
+#define IUnknown_QueryInterface(this,riid,ppvObject)	\
+    (this)->lpVtbl->QueryInterface(this,riid,ppvObject)
+
+#define IUnknown_AddRef(this)	(this)->lpVtbl->AddRef(this)
+
+#define IUnknown_Release(this)	(this)->lpVtbl->Release(this)
+#endif
+
+#ifndef S_OK
+#define S_OK                      (HRESULT)0x00000000L
+#endif
+#ifndef S_OK
+#define S_FALSE                   (HRESULT)0x00000001L
+#endif
+#ifndef E_POINTER
+#define E_POINTER                 (HRESULT)0x80004003L
+#endif
+#ifndef E_OUTOFMEMORY
+#define E_OUTOFMEMORY             (HRESULT)0x8007000EL
+#endif
+#ifndef E_INVALIDARG
+#define E_INVALIDARG              (HRESULT)0x80070057L
+#endif
+#ifndef E_NOINTERFACE
+#define E_NOINTERFACE             (HRESULT)0x80004002L
+#endif
+#ifndef E_FAIL
+#define E_FAIL                    (HRESULT)0x80004005L
+#endif
+#ifndef CO_E_CLASSSTRING
+#define CO_E_CLASSSTRING          (HRESULT)0x800401F3L
+#endif
+#ifndef CO_E_CLSREG_INCONSISTENT
+#define CO_E_CLSREG_INCONSISTENT  (HRESULT)0x8000401FL
+#endif
+#ifndef DISP_E_EXCEPTION
+#define DISP_E_EXCEPTION          (HRESULT)0x80020009L
+#endif
+#ifndef DISP_E_UNKNOWNNAME
+#define DISP_E_UNKNOWNNAME        (HRESULT)0x80020006L
+#endif
+#ifndef DISP_E_BADPARAMCOUNT
+#define DISP_E_BADPARAMCOUNT      (HRESULT)0x8002000EL
+#endif
+#ifndef DISP_E_PARAMNOTFOUND
+#define DISP_E_PARAMNOTFOUND      (HRESULT)0x80020004L
+#endif
+#ifndef CLASS_E_NOAGGREGATION
+#define CLASS_E_NOAGGREGATION     (HRESULT)0x80040110L
+#endif
+#ifndef CLASS_E_CLASSNOTAVAILABLE
+#define CLASS_E_CLASSNOTAVAILABLE (HRESULT)0x80040111L
+#endif
+
+#ifndef FAILED
+#define FAILED(hr)   ((HRESULT)(hr)<0)
+#endif
+
+extern
+HRESULT
+STDCALL
+OleInitialize ( void* pvReserved );
+
+extern
+void
+STDCALL
+OleUninitialize ();
+
+extern
+HRESULT
+STDCALL
+CoCreateInstance (
+		  REFCLSID   rclsid,
+		  IUnknown*  pUnkOuter,
+		  DWORD      dwClsContext,
+		  REFIID     riid,
+		  void**     ppv);
+
+#if __W32API_MAJOR_VERSION == 1
+extern
+HRESULT
+STDCALL
+CoCreateInstanceEx (
+		  REFCLSID   rclsid,
+		  IUnknown*  pUnkOuter,
+		  DWORD      dwClsContext,
+		  void*      pServerInfo,
+		  ULONG      cmq,
+		  void*      pResults);
+
+extern
+HRESULT
+STDCALL
+CoRegisterClassObject (
+		  REFCLSID   rclsid,
+		  IUnknown*  pUnkOuter,
+		  DWORD      dwClsContext,
+		  DWORD      flags,
+		  DWORD**    pdwRegister);
+#endif
+
+extern
+HRESULT
+STDCALL
+CoRevokeClassObject (
+		  DWORD      dwRegister
+                    );
+
+extern
+HRESULT
+STDCALL
+primCreateInstance (
+		  CLSID*     clsid,
+		  IUnknown*  pUnkOuter,
+		  DWORD      dwClsContext,
+		  IID*       iid,
+		  void**     ppv);
+extern
+HRESULT
+STDCALL
+StringFromCLSID
+             (REFCLSID rclsid,
+	      WCHAR** lplpsz);
+
+extern
+int
+STDCALL
+StringFromGUID2
+             ( const GUID* rguid
+	     , LPOLESTR    lpsz
+	     , int         cbMax
+	     );
+
+extern
+HRESULT
+STDCALL
+ProgIDFromCLSID
+             (REFCLSID rclsid,
+	      WCHAR** lplpsz);
+
+extern
+HRESULT
+STDCALL
+CLSIDFromString
+             (WCHAR* lpsz,
+	      CLSID* pclsid);
+
+/* Helper functions defined in ComPrimSrc.c */
+extern HRESULT primStringToGUID( WCHAR* guidStr, GUID* guid );
+extern char*   hresultString( HRESULT hr );
+extern HRESULT primGUIDToString( CLSID* guid, WCHAR** guidStr );
+extern DWORD   lOCALE_USER_DEFAULT ();
+extern IID*    primNullIID();
+
+extern HRESULT primQI (void* methPtr, void* iptr, void* rclsid, void** ppv);
+extern unsigned int primAddRef (void* methPtr, void* iptr);
+extern unsigned int primRelease(void* methPtr, void* iptr);
+
+extern void releaseIUnknown__(void* iptr);
+extern void* addrOfReleaseIUnknown();
+
+extern HRESULT primEnumNext (void* methPtr, void* iptr, unsigned int celt, void* ptr, void* po);
+extern HRESULT primEnumSkip (void* methPtr, void* iptr, unsigned int celt);
+extern HRESULT primEnumReset (void* methPtr, void* iptr);
+extern HRESULT primEnumClone (void* methPtr, void* iptr,void* ppv);
+
+extern HRESULT primPersistLoad(void* methPtr, void* iptr, void* pszFileName, unsigned int dwMode);
+
+extern HRESULT bstrToStringLen( BSTR bstr, int len, char* p );
+extern int     bstrLen( BSTR bstr );
+extern HRESULT stringToBSTR( const char* p, BSTR* pbstr );
+
+#if __W32API_MAJOR_VERSION == 1
+typedef struct IRunningObjectTable IRunningObjectTable;
+typedef struct IEnumString IEnumString;
+/* Close enough for our purposes.. */
+typedef int BIND_OPTS;
+
+typedef struct IBindCtx IBindCtx;
+
+    typedef struct IBindCtxVtbl
+    {
+        HRESULT ( STDCALL *QueryInterface )
+	           ( IBindCtx * This
+		   , REFIID riid
+		   , void **ppvObject
+		   );
+        
+        ULONG ( STDCALL *AddRef )( IBindCtx * This );
+        
+        ULONG ( STDCALL *Release )( IBindCtx * This );
+        
+        HRESULT ( STDCALL *RegisterObjectBound )
+	           ( IBindCtx * This
+		   , IUnknown *punk
+		   );
+        
+        HRESULT ( STDCALL *RevokeObjectBound )
+	           ( IBindCtx * This
+		   , IUnknown *punk
+		   );
+        
+        HRESULT ( STDCALL *ReleaseBoundObjects )
+	           ( IBindCtx * This );
+        
+        /* [local] */ HRESULT ( STDCALL *SetBindOptions )
+	           ( IBindCtx * This
+		   , BIND_OPTS *pbindopts
+		   );
+        
+        /* [local] */ HRESULT ( STDCALL *GetBindOptions )
+	           ( IBindCtx * This
+		   , BIND_OPTS *pbindopts
+		   );
+        
+        HRESULT ( STDCALL *GetRunningObjectTable )
+	           ( IBindCtx * This
+		   , IRunningObjectTable **pprot
+		   );
+        
+        HRESULT ( STDCALL *RegisterObjectParam )
+	           ( IBindCtx * This
+		   , LPOLESTR pszKey
+		   , IUnknown *punk
+		   );
+        
+        HRESULT ( STDCALL *GetObjectParam )
+	           ( IBindCtx * This
+		   , LPOLESTR pszKey
+		   , IUnknown **ppunk
+		   );
+        
+        HRESULT ( STDCALL *EnumObjectParam )
+	           ( IBindCtx * This
+		   , IEnumString **ppenum
+		   );
+        
+        HRESULT ( STDCALL *RevokeObjectParam )
+	           ( IBindCtx * This
+		   , LPOLESTR pszKey
+		   );
+    } IBindCtxVtbl;
+
+struct IBindCtx { struct IBindCtxVtbl *lpVtbl; };
+
+typedef struct IStream IStream;
+typedef struct IEnumMoniker IEnumMoniker;
+
+typedef struct IMoniker IMoniker;
+    typedef struct IMonikerVtbl
+    {
+        HRESULT ( STDCALL *QueryInterface )
+	           ( IMoniker * This
+		   , REFIID riid
+		   , void **ppvObject
+		   );
+        
+        ULONG ( STDCALL *AddRef )( IMoniker * This );
+        
+        ULONG ( STDCALL *Release )( IMoniker * This );
+
+        HRESULT ( STDCALL *GetClassID )
+	           ( IMoniker * This
+		   , CLSID *pClassID
+		   );
+        
+        HRESULT ( STDCALL *IsDirty )( IMoniker * This );
+        
+        HRESULT ( STDCALL *Load )
+	           ( IMoniker * This
+		   , IStream *pStm
+		   );
+        
+        HRESULT ( STDCALL *Save )
+	           ( IMoniker * This
+		   , IStream *pStm
+		   , BOOL fClearDirty
+		   );
+        
+        HRESULT ( STDCALL *GetSizeMax )
+	           ( IMoniker * This
+		   , ULARGE_INTEGER *pcbSize
+		   );
+        
+        HRESULT ( STDCALL *BindToObject )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , REFIID riidResult
+		   , void **ppvResult
+		   );
+        
+        HRESULT ( STDCALL *BindToStorage )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , REFIID riid
+		   , void **ppvObj
+		   );
+        
+        HRESULT ( STDCALL *Reduce )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , DWORD dwReduceHowFar
+		   , IMoniker **ppmkToLeft
+		   , IMoniker **ppmkReduced
+		   );
+        
+        HRESULT ( STDCALL *ComposeWith )
+	           ( IMoniker * This
+		   , IMoniker *pmkRight
+		   , BOOL fOnlyIfNotGeneric
+		   , IMoniker **ppmkComposite
+		   );
+        
+        HRESULT ( STDCALL *Enum )
+	           ( IMoniker * This
+		   , BOOL fForward
+		   , IEnumMoniker **ppenumMoniker
+		   );
+        
+        HRESULT ( STDCALL *IsEqual )
+	           ( IMoniker * This
+		   , IMoniker *pmkOtherMoniker
+		   );
+        
+        HRESULT ( STDCALL *Hash )
+	           ( IMoniker * This
+		   , DWORD *pdwHash
+		   );
+        
+        HRESULT ( STDCALL *IsRunning )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , IMoniker *pmkNewlyRunning
+		   );
+        
+        HRESULT ( STDCALL *GetTimeOfLastChange )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , FILETIME *pFileTime
+		   );
+        
+        HRESULT ( STDCALL *Inverse )
+	           ( IMoniker * This
+		   , IMoniker **ppmk
+		   );
+        
+        HRESULT ( STDCALL *CommonPrefixWith )
+	           ( IMoniker * This
+		   , IMoniker *pmkOther
+		   , IMoniker **ppmkPrefix
+		   );
+        
+        HRESULT ( STDCALL *RelativePathTo )
+	           ( IMoniker * This
+		   , IMoniker *pmkOther
+		   , IMoniker **ppmkRelPath
+		   );
+        
+        HRESULT ( STDCALL *GetDisplayName )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , LPOLESTR *ppszDisplayName
+		   );
+        
+        HRESULT ( STDCALL *ParseDisplayName )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , LPOLESTR pszDisplayName
+		   , ULONG *pchEaten
+		   , IMoniker **ppmkOut
+		   );
+        
+        HRESULT ( STDCALL *IsSystemMoniker )
+	           ( IMoniker * This
+		   , DWORD *pdwMksys
+		   );
+    } IMonikerVtbl;
+
+struct IMoniker { struct IMonikerVtbl* lpVtbl; };
+
+#define IMoniker_BindToObject(This,pbc,pmkToLeft,riidResult,ppvResult)	\
+    (This)->lpVtbl -> BindToObject(This,pbc,pmkToLeft,riidResult,ppvResult)
+
+typedef struct IEnumUnknown IEnumUnknown;
+
+typedef struct IEnumUnknownVtbl
+    {
+        HRESULT ( STDCALL *QueryInterface )
+	            ( IEnumUnknown * This
+		    , REFIID riid
+		    , void **ppvObject
+		    );
+        
+        ULONG ( STDCALL *AddRef )( IEnumUnknown * This );
+        
+        ULONG ( STDCALL *Release )( IEnumUnknown * This );
+        
+        HRESULT ( STDCALL *Next )
+	            ( IEnumUnknown * This
+		    , ULONG celt
+		    , IUnknown **rgelt
+		    , ULONG *pceltFetched
+		    );
+        
+        HRESULT ( STDCALL *Skip )
+	            ( IEnumUnknown * This
+		    , ULONG celt
+		    );
+        
+        HRESULT ( STDCALL *Reset )(  IEnumUnknown * This );
+        
+        HRESULT ( STDCALL *Clone )( IEnumUnknown * This, IEnumUnknown **ppenum );
+
+    } IEnumUnknownVtbl;
+
+struct IEnumUnknown { IEnumUnknownVtbl* lpVtbl; };
+
+extern
+void*
+STDCALL
+CoTaskMemAlloc(unsigned int size);
+
+void
+STDCALL
+CoTaskMemFree(LPVOID pv);
+
+extern
+HRESULT
+STDCALL
+GetActiveObject (CLSID* clsid, void* reserved, IUnknown** ppunk);
+
+extern BSTR STDCALL SysAllocStringLen(OLECHAR* pch, unsigned int cch);
+extern BSTR STDCALL SysAllocStringByteLen(char* pch, unsigned int len);
+extern void STDCALL SysFreeString(BSTR bstr);
+extern UINT STDCALL SysStringLen(BSTR bstr);
+#endif
+
+extern
+HRESULT
+STDCALL
+MkParseDisplayName( IBindCtx* pbc
+		  , LPCOLESTR szUserName
+		  , unsigned long* eatern
+		  , IMoniker** ppmk);
+
+extern
+HRESULT
+STDCALL
+CreateBindCtx (DWORD reserved, IBindCtx** ppbc);
+
+#if __W32API_MAJOR_VERSION == 1
+extern
+HRESULT
+STDCALL CreateTypeLib ( int syskind, LPCOLESTR szFile, void** ppv);
+
+extern
+HRESULT
+STDCALL CoCreateGuid ( GUID* pguid );
+
+extern
+HRESULT
+STDCALL CreateTypeLib2 ( int syskind, LPCOLESTR szFile, void** ppv);
+#endif
+
+#ifndef STR2UNI 
+#define STR2UNI(unistr, regstr) mbstowcs (unistr, regstr, strlen (regstr)+1)
+#define UNI2STR(regstr, unistr) wcstombs (regstr, unistr, wcslen (unistr)+1)
+#endif 
+
+#if __W32API_MAJOR_VERSION == 1
+BOOL
+STDCALL
+IsEqualGUID (const GUID* g1, const GUID* g2);
+
+HRESULT
+STDCALL
+LoadTypeLib
+             ( LPOLESTR    lpsz
+	     , IUnknown**  ppv
+	     );
+
+HRESULT
+STDCALL
+LoadTypeLibEx
+             ( LPOLESTR    lpsz
+	     , int         kind
+	     , IUnknown**  ppv
+	     );
+
+HRESULT
+STDCALL
+LoadRegTypeLib
+             ( GUID*       rguid
+	     , WORD        wVerMajor
+	     , WORD        wVerMinor
+	     , LCID        lcid
+	     , IUnknown**  ppv
+	     );
+#endif
+
+extern
+HRESULT
+primLoadRegTypeLib 
+                ( GUID* rguid
+		, short wMaj
+		, short wMin
+		, LCID lcid
+		, void** ppv
+		);
+
+#if __W32API_MAJOR_VERSION == 1
+extern
+HRESULT
+STDCALL
+QueryPathOfRegTypeLib
+             ( GUID* rguid
+	     , unsigned short maj
+	     , unsigned short min
+	     , LCID  lcid
+	     , BSTR* pbstr
+	     );
+
+#endif
+
+extern
+BSTR
+primQueryPathOfRegTypeLib
+             ( GUID* rguid
+	     , unsigned short maj
+	     , unsigned short min
+	     );
+
+extern
+char*
+getModuleFileName
+             ( HANDLE hMod
+	     );
+
+#if __W32API_MAJOR_VERSION == 1
+extern
+DWORD
+WINAPI
+GetModuleFileNameA
+             ( HINSTANCE hMod
+	     , LPSTR     lpFileName
+	     , DWORD     size
+	     );
+
+extern
+LCID
+WINAPI
+GetUserDefaultLCID
+             ();
+
+extern
+INT
+STDCALL
+SystemTimeToVariantTime (void* lpSystemTime, double* pvarTime);
+#endif
+
+extern void    messageBox (char* str, char* t, unsigned long x);
+extern HRESULT primCreateTypeLib ( int i, LPOLESTR fname, void** ppv );
+extern BOOL    primComEqual( IUnknown* unk1, IUnknown* unk2 );
+extern HRESULT primCopyGUID( GUID* g1, GUID* g2);
+extern HRESULT primNewGUID( GUID* g1);
+extern HRESULT bindObject( const WCHAR* name, IID* iid, void** unk );
+extern HRESULT primProgIDFromCLSID( const CLSID* clsid, WCHAR** clsidStr );
+extern HRESULT primCLSIDFromProgID( const char* progid, CLSID* clsid );
+extern void    comUnInitialize(void);
+extern HRESULT comInitialize(void);
+extern HRESULT primStringToGUID( WCHAR* guidStr, GUID* guid );
+extern HRESULT primGUIDToString( CLSID* guid, WCHAR** guidStr );
+
+extern void    postQuitMsg();
+extern void    messagePump();
+extern void*   finalNoFree();
+
+extern HANDLE  mkEvent();
+extern void    waitForEvent(HANDLE h);
+extern void    signalEvent(HANDLE h);
+
+extern void primGetVersionInfo ( unsigned long*, unsigned long*, unsigned long*);
+
+#endif /* __COMPRIM_H__ */
+ comlib/safeArrayPrim.h view
@@ -0,0 +1,2 @@+
+extern void primSafeArrayDestroy (void* p);
+ config.mk view
@@ -0,0 +1,37 @@+# Set this to where you've got your Haskell compiler
+#  (used to compile the contents of src/, lib/ and examples/ )
+#
+# The default setting assume that the Haskell compiler you want to
+# use is GHC and is available along your path as 'ghc'.
+HC=ghc
+
+#
+# The C compiler
+#
+CC=gcc
+
+# ghc is capable of generating Makefile dependencies too,
+# just feed it the -M flag.
+MKDEPENDHS=$(HC)
+
+#
+# Happy (only needed if you want to change the grammars.)
+#
+HAPPY=../../happy/src/happy -g
+
+#
+# Installation setup:
+#
+#  bindir   = directory where the IDL compiler will be installed (and maybe also a library DLL.)
+#  libdir   = location where the *.a will go
+#  datadir  = where to install the GHC interface files (.hi)
+#
+#  hugslibdir  = location of the Hugs98 library directory
+#
+# If you're only interested in installing the Hugs specific bits, do 'make install-hugs' (after
+# having configured `hugslibdir' below.)
+
+#bindir=/usr/local/bin
+#libdir=/usr/local/lib
+#datadir=/usr/local/lib/ghc-4.08
+#hugslibdir=/hugs98/lib
+ hdirect.cabal view
@@ -0,0 +1,138 @@+Name:               hdirect+Version:            0.21.0+Synopsis:           An IDL compiler for Haskell+Description:+    HaskellDirect is an IDL compiler for Haskell, which offers a helping+    hand to the Haskell programmer that wants to better interact with+    and reuse external code.+ . +    Interfacing Haskell code to external code involves the conversion of+    values between the Haskell world and the outside, as data+    representations and details of how memory is managed, are worlds+    apart at times. Manually writing the boilerplate code that takes+    care of this conversion is about as exciting as watching grass grow+    and, as a result, error prone.+ .+    Using an Interface Definition Language (IDL) as basis, HaskellDirect+    automates the generation of such impedance matching code, generating+    all the necessary marshaling code for you.+ . +    With IDL, the functionality provided by a programming interface is+    specified in a programming language neutral framework. The+    HaskellDirect IDL compiler converts this specification into a set of+    method stubs. Depending on how the compiler is invoked, these stubs+    can be used to:+ .+ * Call upon external functions from within Haskell, HaskellDirect creates bindings to external (C-callable) libraries.+ . + * Let external code call upon Haskell functions, HaskellDirect creates foreign/external language interfaces to Haskell libraries.+ .+ * Call COM (Microsoft's Component Object Model) methods from Haskell, HaskellDirect helps you use Microsoft COM components from within Haskell.  The generated stubs can be used with Hugs98 or GHC.+ .+ * Create COM method wrappers, HaskellDirect packages up Haskell code as COM components.+ .+    The HaskellDirect IDL compiler currently groks both the OSF DCE+    dialect of IDL (including the various extensions introduced by the+    Microsoft IDL compiler) and the OMG IIOP/CORBA dialect. (Only the+    former can be used for describing COM interfaces.) + .+homepage:           http://www.haskell.org/hdirect/+License:            BSD3+License-File:       LICENSE+Author:             Sigbjorn Finne+Maintainer:         Don Stewart <dons@galois.com>+Copyright:          1998-2003 University of Glasgow and Sigbjorn Finne. 2010 Don Stewart+Stability:          Stable+Category:           Development+Build-type:         Simple+cabal-version:      >= 1.6++source-repository head+    type:     darcs+    location: http://code.haskell.org/~dons/code/hdirect++Executable hdirect+    hs-source-dirs:  src+    Main-Is:            Main.lhs+    ghc-options:        -Wall+    build-tools:        happy+    build-depends:      haskell98,+                        base >= 2 && < 5,+                        pretty,+                        array++library+    hs-source-dirs:  src+    build-tools:        happy+    build-depends:      haskell98,+                        base >= 2 && < 5,+                        pretty,+                        array++    exposed-modules:+        AbsHUtils+        AbstractH+        Attribute+        Bag+        BasicTypes+        CStubGen+        CgMonad+        CodeGen+        CoreIDL+        CoreUtils+        CustomAttributes+        DefGen+        Desugar+        Digraph+        DsMonad+        Env+        FiniteMap+        GetOpt+        HugsCodeGen+        IDLSyn+        IDLToken+        IDLUtils+        ImportLib+        JavaProxy+        Lex+        LexM+        LibUtils+        Literal+        Main+        MarshallAbstract+        MarshallAuto+        MarshallCore+        MarshallDep+        MarshallEnum+        MarshallFun+        MarshallJNI+        MarshallJServ+        MarshallMethod+        MarshallMonad+        MarshallServ+        MarshallStruct+        MarshallType+        MarshallUnion+        MarshallUtils+        MkImport+        NameSupply+        NativeInfo+        NormaliseType+        OmgParser+        Opts+        PP+        Parser+        PpAbstractH+        PpCore+        PpIDLSyn+        PreProc+        Rename+        RnMonad+        Skeleton+        SrcLoc+        SymbolTable+        TLBWriter+        TypeInfo+        Utils+        Validate+        Version
+ install-sh view
@@ -0,0 +1,238 @@+#!/bin/sh
+#
+# install - install a program, script, or datafile
+# This comes from X11R5.
+#
+# Calling this script install-sh is preferred over install.sh, to prevent
+# `make' implicit rules from creating a file called install from it
+# when there is no Makefile.
+#
+# This script is compatible with the BSD install script, but was written
+# from scratch.
+#
+
+
+# set DOITPROG to echo to test this script
+
+# Don't use :- since 4.3BSD and earlier shells don't like it.
+doit="${DOITPROG-}"
+
+
+# put in absolute paths if you don't have them in your path; or use env. vars.
+
+mvprog="${MVPROG-mv}"
+cpprog="${CPPROG-cp}"
+chmodprog="${CHMODPROG-chmod}"
+chownprog="${CHOWNPROG-chown}"
+chgrpprog="${CHGRPPROG-chgrp}"
+stripprog="${STRIPPROG-strip}"
+rmprog="${RMPROG-rm}"
+mkdirprog="${MKDIRPROG-mkdir}"
+
+tranformbasename=""
+transform_arg=""
+instcmd="$mvprog"
+chmodcmd="$chmodprog 0755"
+chowncmd=""
+chgrpcmd=""
+stripcmd=""
+rmcmd="$rmprog -f"
+mvcmd="$mvprog"
+src=""
+dst=""
+dir_arg=""
+
+while [ x"$1" != x ]; do
+    case $1 in
+	-c) instcmd="$cpprog"
+	    shift
+	    continue;;
+
+	-d) dir_arg=true
+	    shift
+	    continue;;
+
+	-m) chmodcmd="$chmodprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-o) chowncmd="$chownprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-g) chgrpcmd="$chgrpprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-s) stripcmd="$stripprog"
+	    shift
+	    continue;;
+
+	-t=*) transformarg=`echo $1 | sed 's/-t=//'`
+	    shift
+	    continue;;
+
+	-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
+	    shift
+	    continue;;
+
+	*)  if [ x"$src" = x ]
+	    then
+		src=$1
+	    else
+		# this colon is to work around a 386BSD /bin/sh bug
+		:
+		dst=$1
+	    fi
+	    shift
+	    continue;;
+    esac
+done
+
+if [ x"$src" = x ]
+then
+	echo "install:	no input file specified"
+	exit 1
+else
+	true
+fi
+
+if [ x"$dir_arg" != x ]; then
+	dst=$src
+	src=""
+	
+	if [ -d $dst ]; then
+		instcmd=:
+	else
+		instcmd=mkdir
+	fi
+else
+
+# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
+# might cause directories to be created, which would be especially bad 
+# if $src (and thus $dsttmp) contains '*'.
+
+	if [ -f $src -o -d $src ]
+	then
+		true
+	else
+		echo "install:  $src does not exist"
+		exit 1
+	fi
+	
+	if [ x"$dst" = x ]
+	then
+		echo "install:	no destination specified"
+		exit 1
+	else
+		true
+	fi
+
+# If destination is a directory, append the input filename; if your system
+# does not like double slashes in filenames, you may need to add some logic
+
+	if [ -d $dst ]
+	then
+		dst="$dst"/`basename $src`
+	else
+		true
+	fi
+fi
+
+## this sed command emulates the dirname command
+dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
+
+# Make sure that the destination directory exists.
+#  this part is taken from Noah Friedman's mkinstalldirs script
+
+# Skip lots of stat calls in the usual case.
+if [ ! -d "$dstdir" ]; then
+defaultIFS='	
+'
+IFS="${IFS-${defaultIFS}}"
+
+oIFS="${IFS}"
+# Some sh's can't handle IFS=/ for some reason.
+IFS='%'
+set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
+IFS="${oIFS}"
+
+pathcomp=''
+
+while [ $# -ne 0 ] ; do
+	pathcomp="${pathcomp}${1}"
+	shift
+
+	if [ ! -d "${pathcomp}" ] ;
+        then
+		$mkdirprog "${pathcomp}"
+	else
+		true
+	fi
+
+	pathcomp="${pathcomp}/"
+done
+fi
+
+if [ x"$dir_arg" != x ]
+then
+	$doit $instcmd $dst &&
+
+	if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
+	if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
+	if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
+	if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
+else
+
+# If we're going to rename the final executable, determine the name now.
+
+	if [ x"$transformarg" = x ] 
+	then
+		dstfile=`basename $dst`
+	else
+		dstfile=`basename $dst $transformbasename | 
+			sed $transformarg`$transformbasename
+	fi
+
+# don't allow the sed command to completely eliminate the filename
+
+	if [ x"$dstfile" = x ] 
+	then
+		dstfile=`basename $dst`
+	else
+		true
+	fi
+
+# Make a temp file name in the proper directory.
+
+	dsttmp=$dstdir/#inst.$$#
+
+# Move or copy the file name to the temp name
+
+	$doit $instcmd $src $dsttmp &&
+
+	trap "rm -f ${dsttmp}" 0 &&
+
+# and set any options; do chmod last to preserve setuid bits
+
+# If any of these fail, we abort the whole thing.  If we want to
+# ignore errors from any of these, just make sure not to ignore
+# errors from the above "$doit $instcmd $src $dsttmp" command.
+
+	if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
+	if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
+	if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
+	if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
+
+# Now rename the file to the real destination.
+
+	$doit $rmcmd -f $dstdir/$dstfile &&
+	$doit $mvcmd $dsttmp $dstdir/$dstfile 
+
+fi &&
+
+
+exit 0
+ lib/HDirect.h view
@@ -0,0 +1,215 @@+/* --------------------------------------------------------------------------
+ * GreenCard / HaskellDirect include file.
+ *
+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
+ * Haskell Group 1994-99, and is distributed as Open Source software
+ * under the Artistic License; see the file "Artistic" that is included
+ * in the distribution for details.
+ *
+ * sof 4/99 - changed to make it useable with HaskellDirect.
+ * 
+ * $RCSfile: HDirect.h,v $
+ * $Revision: 1.4 $
+ * $Date: 2003/08/18 16:46:42 $
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ *
+ *                                  WARNING
+ *
+ * Most of the code in this file must exactly match corresponding definitions
+ * in the Hugs source code.
+ *
+ * We have chosen to copy this code over to avoid the need to #include huge
+ * chunks of the Hugs internal definitions (which sometimes conflict with
+ * Xlib, Win32 or other libraries which we might also have to #include).
+ *
+ *
+ * sof 4/99 - removed #include of config.h and options.h, since its only use
+ *            appeared to be to pick up whether the host C compiler supported
+ *            prototypes or not. Most do nowadays.
+ * ------------------------------------------------------------------------*/
+
+#ifndef __HDIRECT_H__
+#define __HDIRECT_H__
+
+#if 1 /* PROTOTYPES */   /* To enable use of prototypes whenever possible */
+#define Args(x) x
+#else
+#define Args(x) ()
+#endif
+
+typedef unsigned char      hugs_uint8_t;
+typedef unsigned short     hugs_uint16_t;
+typedef unsigned int       hugs_uint32_t;
+typedef signed   char      hugs_int8_t;
+typedef signed   short     hugs_int16_t;
+typedef signed   int       hugs_int32_t;
+# ifdef _MSC_VER
+typedef unsigned __int64   hugs_uint64_t;
+typedef          __int64   hugs_int64_t;
+# else
+typedef unsigned long long hugs_uint64_t;
+typedef signed   long long hugs_int64_t;
+# endif
+
+typedef int            HsInt;        
+typedef hugs_int8_t    HsInt8;         
+typedef hugs_int16_t   HsInt16;        
+typedef hugs_int32_t   HsInt32;        
+typedef unsigned int   HsWord;       
+typedef hugs_uint8_t   HsWord8;        
+typedef hugs_uint16_t  HsWord16;       
+typedef hugs_uint32_t  HsWord32;       
+
+/* 
+ * Here we deviate from the FFI specification:
+ * If we make them both float, then there's no way to pass a double
+ * to C which means we can't call common C functions like sin.
+ */           
+typedef float          HsFloat;      
+typedef double         HsDouble;     
+
+typedef hugs_int64_t   HsInt64;        
+typedef hugs_uint64_t  HsWord64;       
+typedef char           HsChar;
+typedef int            HsBool;         
+typedef void*          HsAddr;       
+typedef void*          HsPtr;          
+typedef void           (*HsFunPtr)(void);
+typedef void*          HsForeignPtr;   
+typedef void*          HsStablePtr;  
+
+typedef int   HugsStackPtr;
+typedef int   HugsStablePtr;
+typedef void* HugsForeign;
+
+
+#define primFun(name)	 static void name(HugsStackPtr hugs_root)
+#define hugs_returnIO(n) hugs->returnIO(hugs_root,n)
+#define hugs_returnId(n) hugs->returnId(hugs_root,n)
+
+/* These declarations must exactly match those in storage.h */
+
+typedef void (*Prim) Args((HugsStackPtr)); /* primitive function	   */
+
+extern struct hugs_primitive {		/* table of primitives		   */
+    char*  ref;				/* primitive reference string	   */
+    int	   arity;			/* primitive function arity	   */
+    Prim   imp;				/* primitive implementation	   */
+} primitives[];
+
+struct hugs_primInfo {
+    void                   (*controlFun) Args((int));
+    struct hugs_primitive  *primFuns;
+    struct hugs_primInfo   *nextPrimInfo;
+};
+
+/* This is an exact copy of the declaration found in storage.h */
+
+typedef struct {
+
+  /* evaluate next argument */
+  HsInt          (*getInt)         (void);
+  HsWord         (*getWord)        (void);
+  HsAddr    	 (*getAddr)        (void);
+  HsFloat        (*getFloat)       (void);
+  HsDouble       (*getDouble)      (void);
+  HsChar         (*getChar)        (void);
+  HugsForeign    (*getForeign)     (void);
+  HugsStablePtr  (*getStablePtr)   (void); /* deprecated */
+
+  /* push part of result   */
+  void           (*putInt)         (HsInt);
+  void      	 (*putWord)        (HsWord);
+  void      	 (*putAddr)        (HsAddr);
+  void           (*putFloat)       (HsFloat);
+  void           (*putDouble)      (HsDouble);
+  void           (*putChar)        (HsChar);
+  void      	 (*putForeign)     (HugsForeign, void (*)(HugsForeign));
+  void           (*putStablePtr)   (HugsStablePtr); /* deprecated */
+
+  /* return n values in IO monad or Id monad */
+  void      	 (*returnIO)       (HugsStackPtr, int);
+  void      	 (*returnId)       (HugsStackPtr, int);
+  int      	 (*runIO)          (int);
+
+  /* free a stable pointer */	    			 
+  void      	 (*freeStablePtr)  (HugsStablePtr); /* deprecated */
+
+  /* register the prim table */	    			 
+  void      	 (*registerPrims)  (struct hugs_primInfo*);
+			   
+  /* garbage collect */
+  void		 (*garbageCollect) (void);
+
+  /* API3 additions follow */
+  HugsStablePtr  (*lookupName)     (char*, char*);
+  void           (*ap)             (int);
+  void           (*getUnit)        (void);
+  void*          (*mkThunk)        (HsFunPtr, HugsStablePtr);
+  void           (*freeThunk)      (void*);
+  HsBool         (*getBool)        (void);
+  void           (*putBool)        (HsBool);
+
+  /* API4 additions follow */
+  HsInt8         (*getInt8)        (void);
+  HsInt16        (*getInt16)       (void);
+  HsInt32        (*getInt32)       (void);
+  HsInt64        (*getInt64)       (void);
+  HsWord8        (*getWord8)       (void);
+  HsWord16       (*getWord16)      (void);
+  HsWord32       (*getWord32)      (void);
+  HsWord64       (*getWord64)      (void);
+  HsPtr          (*getPtr)         (void);
+  HsFunPtr       (*getFunPtr)      (void);
+  HsForeignPtr   (*getForeignPtr)  (void);
+
+  void           (*putInt8)        (HsInt8);
+  void           (*putInt16)       (HsInt16);
+  void           (*putInt32)       (HsInt32);
+  void           (*putInt64)       (HsInt64);
+  void           (*putWord8)       (HsWord8);
+  void           (*putWord16)      (HsWord16);
+  void           (*putWord32)      (HsWord32);
+  void           (*putWord64)      (HsWord64);
+  void           (*putPtr)         (HsPtr);
+  void           (*putFunPtr)      (HsFunPtr);
+  void           (*putForeignPtr)  (HsForeignPtr);
+
+  HugsStablePtr  (*makeStablePtr4) (void);
+  void           (*derefStablePtr4)(HugsStablePtr);
+
+  void           (*putStablePtr4)  (HsStablePtr);
+  HsStablePtr    (*getStablePtr4)  (void);
+  void      	 (*freeStablePtr4) (HsStablePtr);
+
+  int      	 (*runId)          (int);
+} HugsAPI4;
+
+HugsAPI4 *hugs; /* pointer to virtual function table */
+
+/* 
+  copyBytes() is needed when dealing with 
+  functions that return structs
+
+  Note: we're (intentionally!) relying on memcpy() to handle
+  malloc() failure for us.
+*/
+#define copyBytes(len,struct_ptr) \
+    memcpy((char*)malloc(len*sizeof(char)),(char*)(struct_ptr), len)
+
+/* Copied verbatim from prelude.h */
+
+#ifdef _MSC_VER /* Microsoft Visual C++ */
+#define DLLIMPORT(rty) __declspec(dllimport) rty
+#define DLLEXPORT(rty) __declspec(dllexport) rty
+#elif defined __BORLANDC__ 
+#define DLLIMPORT(rty) rty far _import
+#define DLLEXPORT(rty) rty far _export
+#else 
+#define DLLIMPORT(rty) rty
+#define DLLEXPORT(rty) rty
+#endif /* Don't need to declare DLL exports */
+
+#endif /* __HDIRECT_H__ */
+ lib/HDirect.lhs view
@@ -0,0 +1,1137 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+
+Stubs for marshalling and unmarshalling primitive
+types.
+
+\begin{code}
+{-# OPTIONS -#include "PointerSrc.h" #-}
+module HDirect 
+	(
+	  module HDirect
+
+	, Int8
+	, Int16
+	, Int32
+	, Int64
+
+	, Word8
+	, Word16
+	, Word32
+	, Word64
+
+	, Char
+	, Double
+	, Float
+	, Bool
+	
+	, Ptr
+
+	, StablePtr
+	, deRefStablePtr
+	, free
+	
+	) where
+
+import Char
+import Int  ( Int8, Int16, Int32, Int64 )
+import Word ( Word8, Word16, Word32, Word64 )
+--import Addr
+import Monad
+import Pointer
+import System.IO.Unsafe ( unsafePerformIO )
+
+
+import Foreign.StablePtr
+import Foreign.Storable
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Foreign.C.Types ( CChar )
+import Foreign.C.String
+import Foreign.Marshal.Alloc (mallocBytes, free)
+
+import Bits
+{- BEGIN_GHC_ONLY
+import GlaExts ( Int(..), Int# )
+#if __GLASGOW_HASKELL__ >= 505
+import GHC.Base ( getTag )
+#else
+import GlaExts ( dataToTag# )
+getTag :: a -> Int#
+getTag x = dataToTag# x
+{- WAS: x `seq` dataToTag# x
+        this won't work 
+	  (seq's type is a->b->b, where b isn't 'open',
+           but has to be of kind *)
+-}
+#endif
+   END_GHC_ONLY -}
+
+infixl 5 .+.
+
+{- BEGIN_GHC_ONLY
+#if __GLASGOW_HASKELL__ >= 601
+foreignPtrToPtr = unsafeForeignPtrToPtr
+#endif
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+-- Versionitis. If your version of Hugs is troubled by this one, simply comment it out.
+foreignPtrToPtr = unsafeForeignPtrToPtr
+{- END_NOT_FOR_GHC -}
+\end{code}
+
+At the moment the IDL compiler will emit calls to types with identity marshallers
+(i.e., by-value marshallers for primitive, FFI-recognised types), so we need
+to provide stubs for these here.
+
+
+Int* marshalling functions:
+
+\begin{code}
+marshallInt :: Int -> IO Int
+marshallInt x = return x
+
+unmarshallInt :: Int -> IO Int
+unmarshallInt x = return x
+
+writeInt :: Ptr Int -> Int -> IO ()
+writeInt ptr v = poke ptr v
+
+readInt :: Ptr Int -> IO Int
+readInt ptr = peek ptr
+
+--ToDo: generate host-specific versions of 
+sizeofInt :: Word32
+sizeofInt = fromIntegral (sizeOf (0 :: Int))
+
+--Int8
+marshallInt8 :: Int8 -> IO Int8
+marshallInt8 v = return v
+
+unmarshallInt8 :: Int8 -> IO Int8
+unmarshallInt8 v = return v
+
+writeInt8 :: Ptr Int8 -> Int8 -> IO ()
+writeInt8 ptr v = poke ptr v
+
+readInt8 :: Ptr Int8 -> IO Int8
+readInt8 ptr = peek ptr
+
+sizeofInt8 :: Word32
+sizeofInt8 = fromIntegral (sizeOf (1 :: Int8))
+
+--Int16
+marshallInt16 :: Int16 -> IO Int16
+marshallInt16 x = return x
+unmarshallInt16 :: Int16 -> IO Int16
+unmarshallInt16 x = return x
+
+writeInt16 :: Ptr Int16 -> Int16 -> IO ()
+writeInt16 ptr v = poke ptr v
+
+readInt16 :: Ptr Int16 -> IO Int16
+readInt16 ptr = peek ptr
+
+sizeofInt16 :: Word32
+sizeofInt16 = fromIntegral (sizeOf (0 :: Int16))
+
+-- Int32
+marshallInt32 :: Int32 -> IO Int32
+marshallInt32 x = return x
+
+unmarshallInt32 :: Int32 -> IO Int32
+unmarshallInt32 x = return x
+
+writeInt32 :: Ptr Int32 -> Int32 -> IO ()
+writeInt32 ptr v = poke ptr v
+
+readInt32 :: Ptr Int32 -> IO Int32
+readInt32 ptr = peek ptr
+
+sizeofInt32 :: Word32
+sizeofInt32 = fromIntegral (sizeOf (0::Int32))
+
+marshallInt64 :: Int64 -> IO Int64
+marshallInt64 x = return x
+
+unmarshallInt64 :: Int64 -> IO Int64
+unmarshallInt64 x = return x
+
+writeInt64 :: Ptr Int64 -> Int64 -> IO ()
+readInt64 :: Ptr Int64 -> IO Int64
+writeInt64 ptr v = poke ptr v
+readInt64 ptr = peek ptr
+{-
+{- BEGIN_NOT_FOR_GHC -}
+writeInt64 ptr v = writeI64 ptr (fromIntegral lo) (fromIntegral hi)
+ where
+   (hi,lo) = (fromIntegral v) `divMod` (toInteger (maxBound :: Int) + 1)
+readInt64 ptr = do
+  px <- readI64 ptr
+  lo <- peekElemOff px 0
+  hi <- peekElemOff px 1
+  free ptr
+  return (fromIntegral ((toInteger lo) + (toInteger hi) * (toInteger (maxBound :: Int) + 1)))
+{- END_NOT_FOR_GHC -}
+-}
+
+sizeofInt64 :: Word32
+sizeofInt64 = fromIntegral (sizeOf (0 :: Int64))
+
+type Hyper   = Int64
+marshallHyper :: Hyper -> IO Int64
+unmarshallHyper :: Int64 -> IO Hyper
+writeHyper :: Ptr Hyper -> Hyper -> IO ()
+readHyper :: Ptr Hyper -> IO Hyper
+sizeofHyper :: Word32
+
+marshallHyper   = marshallInt64
+unmarshallHyper = unmarshallInt64
+writeHyper      = writeInt64
+readHyper       = readInt64
+sizeofHyper     = fromIntegral (sizeOf (0 :: Int64))
+
+writeInteger :: Ptr Integer -> Integer -> IO ()
+writeInteger ptr x = writeInt64 (castPtr ptr) (fromIntegral x)
+
+readInteger :: Ptr Integer -> IO Integer
+readInteger ptr = do
+  x <- readInt64 (castPtr ptr)
+  return (fromIntegral x)
+
+marshallInteger :: Integer -> IO (Int32, Int32)
+marshallInteger i =  return (fromInteger lo, fromInteger hi)
+ where
+   (hi,lo) = i `divMod` (toInteger (maxBound :: Int) + 1)
+
+unmarshallInteger :: (Int32,Int32) -> IO Integer
+unmarshallInteger (hi,lo) =  return ((toInteger lo) + (toInteger hi) * (toInteger (maxBound :: Int) + 1))
+
+marshallUInteger :: Integer -> IO (Int32, Int32)
+marshallUInteger = marshallInteger
+
+unmarshallUInteger :: (Int32,Int32) -> IO Integer
+unmarshallUInteger = unmarshallInteger
+
+readUInteger :: Ptr Integer -> IO Integer
+readUInteger = readInteger
+
+writeUInteger :: Ptr Integer -> Integer -> IO ()
+writeUInteger = writeInteger
+
+\end{code}
+
+Characters and bytes:
+
+NOTE: we assume that Char is CChar (==an 8-bit byte.)
+
+\begin{code}
+marshallChar :: Char -> IO Char
+marshallChar x = return x
+
+unmarshallChar :: Char -> IO Char
+unmarshallChar x = return x
+
+writeChar :: Ptr Char -> Char -> IO ()
+writeChar ptr v = poke ((castPtr ptr) :: Ptr CChar) (castCharToCChar v)
+
+readChar :: Ptr Char -> IO Char
+readChar ptr = peek ((castPtr ptr) :: Ptr CChar) >>= return.castCCharToChar
+
+sizeofChar :: Word32
+sizeofChar     = fromIntegral (sizeOf (undefined :: CChar))
+
+-- wide chars.
+type Wchar_t = Word16
+
+marshallWchar_t :: Wchar_t -> IO Wchar_t
+marshallWchar_t   = marshallWord16
+unmarshallWchar_t :: Wchar_t -> IO Wchar_t
+unmarshallWchar_t = unmarshallWord16
+writeWchar_t :: Ptr Wchar_t -> Wchar_t -> IO ()
+writeWchar_t      = writeWord16
+readWchar_t :: Ptr Wchar_t -> IO Wchar_t
+readWchar_t       = readWord16
+sizeofWchar_t :: Word32
+sizeofWchar_t     = fromIntegral (sizeOf (0::Word16))
+
+
+type Octet   = Byte
+type Byte    = Word8
+
+marshallByte :: Byte -> IO Byte
+marshallByte   = marshallWord8
+unmarshallByte :: Byte -> IO Byte
+unmarshallByte = unmarshallWord8
+writeByte :: Ptr Byte -> Byte -> IO ()
+writeByte      = writeWord8
+readByte :: Ptr Byte -> IO Byte
+readByte       = readWord8
+sizeofByte :: Word32
+sizeofByte     = fromIntegral (sizeOf (0::Word8))
+\end{code}
+
+Words:
+
+\begin{code}
+-- Word8:
+marshallWord8 :: Word8 -> IO Word8
+marshallWord8 x = return x
+
+unmarshallWord8 :: Word8 -> IO Word8
+unmarshallWord8 x = return x
+
+writeWord8 :: Ptr Word8 -> Word8 -> IO ()
+writeWord8 ptr v = poke ptr v
+
+readWord8 :: Ptr Word8 -> IO Word8
+readWord8 ptr = peek ptr
+
+sizeofWord8 :: Word32
+sizeofWord8 = fromIntegral (sizeOf (undefined :: Word8))
+
+-- Word16:
+marshallWord16 :: Word16 -> IO Word16
+marshallWord16 x = return x
+
+unmarshallWord16 :: Word16 -> IO Word16
+unmarshallWord16 x = return x
+
+writeWord16 :: Ptr Word16 -> Word16 -> IO ()
+writeWord16 ptr v = poke ptr v
+
+readWord16 :: Ptr Word16 -> IO Word16
+readWord16 ptr = peek ptr
+
+sizeofWord16 :: Word32
+sizeofWord16 = fromIntegral (sizeOf (undefined :: Word16))
+
+-- Word32:
+marshallWord32 :: Word32 -> IO Word32
+marshallWord32 x = return x
+
+unmarshallWord32 :: Word32 -> IO Word32
+unmarshallWord32 x = return x
+
+writeWord32 :: Ptr Word32 -> Word32 -> IO ()
+writeWord32 ptr v = poke ptr v
+
+readWord32 :: Ptr Word32 -> IO Word32
+readWord32 ptr = peek ptr
+
+sizeofWord32 :: Word32
+sizeofWord32 = fromIntegral (sizeOf (undefined :: Word32))
+
+marshallWord64 :: Word64 -> IO Word64
+marshallWord64 x = return x
+
+unmarshallWord64 :: Word64 -> IO Word64
+unmarshallWord64 x = return x
+
+writeWord64 :: Ptr Word64 -> Word64 -> IO ()
+readWord64 :: Ptr Word64 -> IO Word64
+{- BEGIN_NOT_FOR_GHC -}
+writeWord64 _ _ = undefined
+readWord64 _ = undefined
+{- END_NOT_FOR_GHC -}
+{- BEGIN_GHC_ONLY
+writeWord64 p v = poke p v
+readWord64 p = peek p
+   END_GHC_ONLY -}
+
+sizeofWord64 :: Word32
+sizeofWord64 = fromIntegral (sizeOf (undefined :: Word64))
+
+\end{code}
+
+Addr marshallers:
+
+begin{code}
+marshallAddr :: Ptr Addr -> IO Addr
+marshallAddr p = return p
+
+unmarshallAddr :: Ptr Addr -> IO Addr
+unmarshallAddr p = return p
+
+writeAddr :: Ptr Addr -> Addr -> IO ()
+{- BEGIN_DEBUG
+writeAddr ptr a | ptr == nullAddr = ioError (userError "writeAddr: NULL pointer")
+   END_DEBUG -}
+writeAddr ptr a = writeAddrOffAddr ptr 0 a
+
+readAddr :: Ptr Addr -> IO Addr
+readAddr a = readAddrOffAddr a 0
+
+sizeofAddr :: Word32
+sizeofAddr     = fromIntegral (sizeOf (undefined :: Foreign.Ptr.Ptr ()))
+
+freeAddr :: Addr -> IO ()
+freeAddr = free
+end{code}
+
+Double marshallers:
+
+\begin{code}
+marshallDouble :: Double -> IO Double
+marshallDouble x = return x
+
+unmarshallDouble :: Double -> IO Double
+unmarshallDouble x = return x
+
+writeDouble :: Ptr Double -> Double -> IO ()
+writeDouble ptr x = poke ptr x
+
+readDouble :: Ptr Double -> IO Double
+readDouble ptr = peek ptr
+
+sizeofDouble :: Word32
+sizeofDouble   = fromIntegral (sizeOf (undefined :: Double))
+
+writeFloat :: Ptr Float -> Float -> IO ()
+writeFloat ptr x = poke ptr x
+
+readFloat :: Ptr Float -> IO Float
+readFloat ptr = peek ptr
+
+sizeofFloat :: Word32
+sizeofFloat   = fromIntegral (sizeOf (undefined :: Float))
+
+\end{code}
+
+Booleans - represented externally by a long (Int32):
+
+\begin{code}
+marshallBool :: Bool -> IO Int32
+marshallBool v = marshallInt32 (if v then (-1) else 0)
+
+unmarshallBool :: Int32 -> IO Bool
+unmarshallBool v = return (v /= 0)
+
+writeBool :: Ptr Bool -> Bool -> IO ()
+writeBool ptr v = writeInt32 (castPtr ptr) (if v then (-1) else 0)
+
+readBool :: Ptr Bool -> IO Bool
+readBool ptr = do
+  v <- readInt32 (castPtr ptr)
+  return ( v /= 0 )
+
+sizeofBool :: Word32
+sizeofBool = fromIntegral (sizeOf (0 :: Int32))
+\end{code}
+
+\begin{code}
+addNCastPtr :: Ptr a -> Word32 -> Ptr b
+addNCastPtr v off = v `plusPtr` (fromIntegral off)
+
+derefPtr :: Ptr (Ptr a) -> IO (Ptr a)
+derefPtr p = peek p
+
+indexPtr :: Ptr (Ptr a) -> Int -> IO (Ptr a)
+indexPtr p off = peekElemOff p off
+\end{code}
+
+The unit of allocation is an 8-bit byte.
+
+\begin{code}
+allocOutPtr :: IO (Ptr a)
+allocOutPtr = alloc 4 -- 4 bytes in a pointer. ToDo: 64-bit platform'ify.
+
+allocBytes :: Int -> IO (Ptr a)
+allocBytes len = alloc (fromIntegral len)
+
+allocWords :: Int -> IO (Ptr a)
+allocWords len = alloc (4 * fromIntegral len)
+
+
+alloc :: Word32 -> IO (Ptr a)
+alloc s = mallocBytes (fromIntegral s)
+
+doThenFree ::(Ptr a -> IO ()) -> (Ptr b -> IO c) -> Ptr d -> IO c
+doThenFree f act ptr = do
+   v <- act (castPtr ptr)
+   f (castPtr ptr)
+   return v
+
+trivialFree :: a -> IO ()
+trivialFree _ = return ()
+
+fillIn :: Int -> (Ptr a -> IO ()) -> IO (Ptr a)
+fillIn sz refreemarshall = do
+  ptr <- allocBytes sz
+  refreemarshall ptr
+  return ptr
+
+\end{code}
+
+[ptr]Ptr marshalling
+
+\begin{code}
+marshallPtr :: Ptr a -> IO (Ptr a)
+marshallPtr v = return v
+
+unmarshallPtr :: Ptr a -> IO (Ptr a)
+unmarshallPtr v = return v
+
+writePtr :: Ptr (Ptr a) -> Ptr a -> IO ()
+writePtr a v = poke a v
+
+readPtr :: Ptr a -> IO (Ptr b)
+readPtr a = peek (castPtr a)
+
+writefptr :: Ptr b -> ForeignPtr a -> IO ()
+writefptr p v = poke (castPtr p) (foreignPtrToPtr v)
+\end{code}
+
+[unique]Ptr marshalling
+
+\begin{code}
+marshallunique :: (IO (Ptr a))
+               -> (Ptr a -> a -> IO ())
+	       -> Maybe a
+	       -> IO (Ptr a)
+marshallunique allocRef marshallInto mb = 
+  case mb of
+    Nothing -> return nullPtr
+    Just x  -> marshallref allocRef marshallInto x
+
+marshallMaybe :: (a -> IO b) -> b -> Maybe a -> IO b
+marshallMaybe _mshall def  Nothing  = return def
+marshallMaybe mshall  _def (Just x) = mshall x
+
+writeMaybe :: (Ptr a -> a -> IO ())
+           -> Ptr (Maybe a)
+	   -> Maybe a
+	   -> IO ()
+writeMaybe _  ptr Nothing  = writePtr (castPtr ptr) nullPtr
+writeMaybe wr ptr (Just x) = wr (castPtr ptr) x
+
+readMaybe :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
+readMaybe rd ptr
+ | ptr == nullPtr = return Nothing
+ | otherwise      = rd ptr >>= return . Just
+
+writeunique :: IO (Ptr a)
+	    -> (Ptr a -> a -> IO ())
+	    -> Ptr (Maybe a)
+	    -> Maybe a
+	    -> IO ()
+writeunique allocRef marshallInto p mb =
+  case mb of
+    Nothing  -> writePtr (castPtr p) nullPtr
+    Just x   -> writeref allocRef marshallInto (castPtr p) x
+
+unmarshallunique :: (Ptr a -> IO a) -> Ptr a -> IO (Maybe a)
+unmarshallunique refUnmarshall ptr
+ | ptr == nullPtr = return Nothing
+ | otherwise      = do
+    x <- unmarshallref refUnmarshall ptr
+    return (Just x)
+
+
+readunique :: (Ptr a -> IO a) -> Ptr b -> IO (Maybe a)
+readunique refUnmarshall ptr
+ | ptr == nullPtr = return Nothing
+ | otherwise      = do
+   v <- readPtr (castPtr ptr)
+   if nullPtr == v then
+      return Nothing
+    else do
+      x <- refUnmarshall (castPtr v)
+      return (Just x)
+
+freeunique :: (Ptr a -> IO ()) -> Ptr (Ptr a) -> IO ()
+freeunique freeptee ptr
+ | ptr == nullPtr = return ()
+ | otherwise      = do
+    ptr' <- derefPtr ptr
+    freeptee ptr'
+    free ptr
+
+\end{code}
+
+Marshalling [unique]void* pointers
+
+\begin{code}
+marshallunique_ptr :: Maybe (Ptr a) -> IO (Ptr a)
+marshallunique_ptr mb = 
+  case mb of
+    Nothing -> marshallPtr nullPtr
+    Just x  -> marshallPtr x
+\end{code}
+
+
+[ref]Ptr marshalling
+
+\begin{code}
+marshallref :: (IO (Ptr a)) -> (Ptr a -> a -> IO ()) -> a -> IO (Ptr a)
+marshallref allocRef marshallInto v = do
+   px <- allocRef
+   marshallInto px v
+   return px
+
+writeref :: (IO (Ptr a)) -> (Ptr a -> a -> IO ()) -> Ptr (Ptr a) -> a -> IO ()
+writeref allocRef marshallInto ptr v = do
+  px <- marshallref allocRef marshallInto v
+  writePtr ptr px
+
+unmarshallref :: (Ptr a -> IO b) -> Ptr a -> IO b
+unmarshallref refUnmarshall ptr = refUnmarshall ptr
+
+readref :: (Ptr a -> IO a) -> Ptr (Ptr a) -> IO a
+readref refUnmarshall ptr = do
+  px <- readPtr ptr
+  unmarshallref refUnmarshall (castPtr px)
+
+freeref :: (Ptr b -> IO ()) -> Ptr a -> IO ()
+freeref free_inner pptr = do
+   ptr <- readPtr (castPtr pptr)
+   free_inner ptr
+   free pptr
+\end{code}
+
+
+All by-reference marshalling and unmarshalling functions
+of enums can be expressed using these two stubs:
+
+\begin{code}
+writeenum16 :: (b -> IO Int16) -> Ptr Int16 -> b -> IO ()
+writeenum16 marshall pv v =
+  marshall v >>= \ x ->
+  writeInt16 pv x
+
+readenum16 :: (Int16 -> IO a) -> Ptr (Int16) -> IO a
+readenum16 unmarshall pv = do
+  v <- readInt16 pv
+  unmarshall v
+
+marshallEnum16 :: Enum a => a -> IO Int16
+marshallEnum16 v = return (fromIntegral (fromEnum v))
+
+unmarshallEnum16 :: Enum a => Int16 -> IO a
+unmarshallEnum16 x = return (toEnum (fromIntegral x))
+
+marshallEnum32 :: Enum a => a -> IO Int32
+marshallEnum32 v = return (fromIntegral (fromEnum v))
+
+unmarshallEnum32 :: Enum a => Int32 -> IO a
+unmarshallEnum32 x = return (toEnum (fromIntegral x))
+
+writeEnum32 :: Enum a => Ptr b -> a -> IO ()
+writeEnum32 p v = writeInt32 (castPtr p) (fromIntegral (fromEnum v))
+
+readEnum32 :: Enum a => Ptr b -> IO a
+readEnum32 p = do
+  x <- readInt32 (castPtr p)
+  return (toEnum (fromIntegral x))
+
+writeEnum16 :: Enum a => Ptr b -> a -> IO ()
+writeEnum16 p v = writeInt16 (castPtr p) (fromIntegral (fromEnum v))
+
+readEnum16 :: Enum a => Ptr b -> IO a
+readEnum16 p = do
+  x <- readInt16 (castPtr p)
+  return (toEnum (fromIntegral x))
+
+\end{code}
+
+\begin{code}
+marshalllist :: Word32
+	     -> (Ptr a -> a -> IO ())
+	     -> [a]
+	     -> IO (Ptr b)
+marshalllist szof writeelt ls = do
+ arr <- alloc (len*szof)
+ foldM writeElt (castPtr arr) ls
+ return (castPtr arr)
+  where
+   len = fromIntegral (length ls)
+
+   writeElt addr v = do
+     writeelt addr v
+     return (addNCastPtr addr szof)
+
+unmarshalllist :: Word32 -> Word32 -> Word32 -> (Ptr any -> IO a) -> Ptr b -> IO [a]
+unmarshalllist szof offset len unpack ptr = do
+ let ptr0 = addNCastPtr ptr (offset*szof)
+ loop ptr0 len
+  where
+   loop _ 0 = return []
+   loop p n = do
+    v  <- unpack p
+    let p' = addNCastPtr p szof
+    vs <- loop p' (n-1)
+    return (v:vs)
+
+unmarshallSingle :: (Ptr a -> IO a) -> Ptr a -> IO [a]
+unmarshallSingle ref ptr 
+ | ptr == nullPtr = return []
+ | otherwise      = do
+      x <- ref ptr
+      return [x]
+
+writelist :: Bool -> Word32 -> (Ptr a -> a -> IO ()) -> Ptr [a] -> [a] -> IO ()
+writelist do_alloc szof writeelt pptr ls = do
+ the_ptr <- 
+    (if do_alloc then do
+        ptr <- alloc (szof * fromIntegral len)
+	writePtr (castPtr pptr) ptr
+	return (castPtr ptr)
+      else
+        return (castPtr pptr))
+ foldM writeElt the_ptr ls
+ return ()
+  where
+   len = length ls
+
+   writeElt addr v = do
+    writeelt addr v
+    return (addNCastPtr addr szof)
+
+readlist :: Word32 -> Word32 -> (Ptr a -> IO a) -> Ptr [a] -> IO [a]
+readlist szof len unpack ptr = do
+ let ptr0 = castPtr ptr
+ loop ptr0 len
+  where
+   loop _ 0 = return []
+   loop p n = do
+    v  <- unpack p
+    let p' = addNCastPtr p szof
+    vs <- loop p' (n-1)
+    return (v:vs)
+
+freelist :: Word32 -> Word32 -> (Ptr a -> IO ()) -> Ptr [a] -> IO ()
+freelist szof len free_elt ptr = do
+	go (castPtr ptr) len
+	free ptr
+  where
+    go _pptr 0 = return ()
+    go pptr  x = do
+       p <- readPtr pptr
+       free_elt p
+       let pptr' = addNCastPtr pptr szof
+       go pptr' (x-1)
+
+\end{code}
+
+Unpacking null terminated character strings:
+
+\begin{code}
+marshallString :: String -> IO (Ptr String)
+marshallString str = do
+ pstr  <- alloc (len*sizeofChar)
+ pstr' <- foldM writeElt (castPtr pstr) str
+ writeChar (castPtr pstr') '\0'
+ return pstr
+  where
+   len = fromIntegral (length str + 1)
+
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+marshallBString :: Int -> String -> IO (Ptr String)
+marshallBString len str = do
+ pstr  <- alloc (len'*sizeofChar)
+ pstr' <- foldM writeElt (castPtr pstr) (take len str)
+ writeChar (castPtr pstr') '\0'
+ return pstr
+  where
+   len' = fromIntegral (len + 1)
+
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+unmarshallString :: Ptr String -> IO String
+unmarshallString ptr
+ | ptr == nullPtr  = return ""
+ | otherwise	   = do
+   let ptr0 = addNCastPtr ptr 0
+   loop ptr0
+  where
+   loop p = do
+    v  <- readChar p
+    if v == '\0'
+     then return []
+     else do
+       let p' = addNCastPtr p sizeofChar
+       vs <- loop p'
+       return (v:vs)
+
+-- at most len chars. or zero terminated.
+unmarshallBString :: Int -> Ptr String -> IO String
+unmarshallBString len ptr
+ | ptr == nullPtr  = return ""
+ | otherwise	   = do
+   let ptr0 = addNCastPtr ptr 0
+   loop ptr0 0
+  where
+   loop _ n | n > len = return ""
+   loop p n = do
+    v  <- readChar p
+    if v == '\0'
+     then return []
+     else do
+       let p' = addNCastPtr p sizeofChar
+       vs <- loop p' (n+1)
+       return (v:vs)
+
+readString :: Ptr (Ptr String) -> IO String
+readString pstr = do
+  ptr <- readPtr pstr
+  unmarshallString ptr
+
+readBString :: Int -> Ptr (Ptr String) -> IO String
+readBString len pstr = do
+  ptr <- readPtr pstr
+  unmarshallBString len ptr
+
+writeString :: Bool -> Ptr String -> String -> IO ()
+writeString do_alloc ppstr str = do
+  pstr <-
+    if not do_alloc then
+       return (castPtr ppstr)
+     else do
+       arr <- alloc (fromIntegral string_len)
+       writePtr (castPtr ppstr) arr
+       return arr
+  pstr' <- foldM writeElt (castPtr pstr) str
+  writeChar (castPtr pstr') '\0'
+ where
+   string_len = length str + 1 {- terminator -}
+
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+writeBString :: Bool -> Int -> Ptr a -> String -> IO ()
+writeBString do_alloc len ptr str = do
+  pstr  <-
+    if do_alloc then
+        alloc (fromIntegral len * sizeofChar)
+    else
+        return (castPtr ptr)
+  pstr' <- foldM writeElt pstr (take len str)
+  writeChar pstr' '\0'
+ where
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+freeString :: Ptr String -> IO ()
+freeString = free
+\end{code}
+
+Sequence marshallers - i.e., R/W a sequence of
+values to/from a list.
+
+\begin{code}
+marshallSequence :: (Ptr a -> a -> IO ())
+		 -> (Ptr a -> IO ())
+		 -> Word32
+		 -> Maybe Word32
+		 -> [a]
+		 -> IO (Ptr a)
+marshallSequence wElt wTermin szElt mbLen ls = do
+   pseq  <- alloc (len*szElt) -- assume that the sequence is packed without gaps.
+   pseq' <- foldM writeElt pseq the_ls
+   wTermin pseq'
+   return pseq'
+  where
+    (len, the_ls) = 
+      case mbLen of
+        Nothing -> (fromIntegral (length ls + 1), ls)
+	Just x  -> (x + 1, take (fromIntegral x) ls)
+
+    writeElt addr v = do
+      wElt addr v
+      return (addNCastPtr addr szElt)
+
+unmarshallSequence :: ( Eq a )
+		   => (Ptr (Ptr a) -> IO a)
+		   -> (Ptr (Ptr a) -> IO Bool)
+		   -> Word32
+		   -> Maybe Word32
+		   -> Ptr (Ptr a)
+		   -> IO [a]
+unmarshallSequence rElt termPred szElt mbLen ptr
+ | ptr == nullPtr  = return []
+ | otherwise	   = do
+   let ptr0 = addNCastPtr ptr 0
+   loop 0 ptr0
+  where
+   lenPred = 
+     case mbLen of
+       Nothing -> const False
+       Just x  -> \ y -> y >= x
+
+   loop len p = do
+    flg <- termPred p
+    if flg || (lenPred len)
+     then return []
+     else do
+       v  <- rElt p
+       let p' = addNCastPtr p szElt
+       vs <- loop (len+1) p'
+       return (v:vs)
+
+readSequence :: ( Eq a )
+	     => (Ptr (Ptr a) -> IO a)
+	     -> (Ptr (Ptr a) -> IO Bool)
+	     -> Word32
+	     -> Maybe Word32
+	     -> Ptr (Ptr a)
+	     -> IO [a]
+readSequence rElt termPred szElt mbLen ptr = do
+  ptr' <- readPtr ptr
+  unmarshallSequence rElt termPred szElt mbLen (castPtr ptr')
+
+writeSequence :: ( Eq a )
+	      => Bool
+	      -> (Ptr a -> a -> IO ())
+	      -> (Ptr a -> IO ())
+	      -> Word32
+	      -> Maybe Word32
+	      -> Ptr a 
+	      -> [a] 
+	      -> IO ()
+writeSequence do_alloc wElt wTermin szElt mbLen ppseq ls = do
+  pseq <-
+    if not do_alloc then
+       return (castPtr ppseq)
+     else do
+       arr <- alloc (szElt * seq_len)
+       writePtr (castPtr ppseq) arr
+       return arr
+  pseq' <- foldM writeElt pseq the_ls
+  wTermin pseq'
+ where
+   (seq_len, the_ls) = 
+      case mbLen of
+        Nothing -> (fromIntegral (length ls + 1), ls)
+	Just x  -> (x + 1, take (fromIntegral x) ls)
+
+   writeElt addr v = do
+     wElt addr v
+     return (addNCastPtr addr szElt)
+
+freeSequence :: Ptr a -> IO ()
+freeSequence = free
+\end{code}
+
+\begin{code}
+-- at most len elements
+marshallblist :: Word32 -> Word32 -> (Ptr a -> a -> IO ()) -> [a] -> IO (Ptr [a])
+marshallblist szof l writeelt ls = do
+ arr <- alloc (l'*szof)
+ foldM writeElt (castPtr arr) ls
+ return arr
+  where
+   l' = atLeast l (fromIntegral (0::Int)) ls
+
+   atLeast len  n _ | len == n = len
+   atLeast _len n [] = n
+   atLeast len  n (_:xs) = atLeast len (n+1) xs
+
+   writeElt addr v = do
+    writeelt addr v
+    return (addNCastPtr addr szof)
+
+writeblist :: Word32 -> Word32 -> (Ptr a -> a -> IO ()) -> Ptr [a] -> [a] -> IO ()
+writeblist szof len writeelt ptr ls = do
+ foldM writeElt (castPtr ptr) (take (fromIntegral len) ls)
+ return ()
+  where
+
+   writeElt addr v = do
+    writeelt addr v
+    return (addNCastPtr addr szof)
+
+readblist :: Word32 -> Word32 -> (Ptr a -> IO a) -> Ptr a -> IO [a]
+readblist szof len unpack ptr = do
+ let ptr0 = castPtr ptr
+ loop ptr0 len
+  where
+   loop _p 0 = return []
+   loop p n  = do
+    v  <- unpack p
+    let p' = addNCastPtr p szof
+    vs <- loop p' (n-1)
+    return (v:vs)
+
+\end{code}
+
+Misc coercion functions/shortcuts:
+(ToDo: try to avoid generating them in the first place!)
+
+\begin{code}
+word16ToInt32 :: Word16 -> Int32
+word16ToInt32 w = fromIntegral w -- intToInt32 (word16ToInt w)
+
+-- This coercion is relying on no exceptions being thrown if
+-- the Word32 > (maxBound::Int32).
+word32ToInt32 :: Word32 -> Int32
+word32ToInt32 w = fromIntegral w
+
+-- This coercion is reling on no exceptions being thrown if w < 0.
+int32ToWord32 :: Int32 -> Word32
+int32ToWord32 w = fromIntegral w
+
+int16ToWord32 :: Int16 -> Word32
+int16ToWord32 w = fromIntegral w -- intToWord32 (int16ToInt w)
+
+intToChar :: Int -> Char
+intToChar = chr
+
+charToInt32 :: Char -> Int32
+charToInt32 c = fromIntegral (ord c)
+
+word32ToChar :: Word32 -> Char
+word32ToChar w = chr (fromIntegral w)
+
+charToWord32 :: Char -> Word32
+charToWord32 c = fromIntegral (ord c)
+
+\end{code}
+
+\begin{code}
+toInt32 :: Integral a => a -> Int32
+toInt32 i = fromIntegral i -- intToInt32 (toInt i)
+
+toInt16 :: Integral a => a -> Int16
+toInt16 i = fromIntegral i -- intToInt16 (toInt i)
+\end{code}
+
+ForeignPtr marshallers:
+
+\begin{code}
+marshallFO :: ForeignPtr a -> IO (ForeignPtr a)
+marshallFO x = return x
+
+unmarshallFO :: ForeignPtr a -> IO (ForeignPtr a)
+unmarshallFO x = return x
+
+writeFO :: Ptr (ForeignPtr a) -> ForeignPtr a -> IO ()
+writeFO ptr fo = poke (castPtr ptr) (foreignPtrToPtr fo)
+
+-- a C pointer, really.
+sizeofForeignPtr :: Word32
+sizeofForeignPtr = sizeofPtr
+
+nullFinaliser :: FunPtr (Ptr a -> IO ())
+nullFinaliser = castFunPtr (castPtrToFunPtr finalNoFree)
+
+nullFO :: ForeignPtr a
+nullFO = unsafePerformIO $ makeFO nullPtr nullFinaliser
+\end{code}
+
+\begin{code}
+readStablePtr :: Ptr (StablePtr a) -> IO (StablePtr a)
+readStablePtr ptr = peek ptr
+\end{code}
+
+Default by-value 'marshallers' for structs and unions.
+
+\begin{code}
+marshallStruct :: String -> a -> IO b
+marshallStruct nm _ = ioError (userError (nm ++ ": Marshalling structs by value is not supported yet."))
+
+unmarshallStruct :: String -> a -> IO c
+unmarshallStruct nm _ = ioError (userError (nm ++ ": Unmarshalling structs by value is not supported yet."))
+
+marshallUnion :: String -> a -> IO b
+marshallUnion nm _ = ioError (userError (nm ++ ": Marshalling unions by value is not supported yet."))
+
+unmarshallUnion :: String -> a -> b -> IO c
+unmarshallUnion nm _ _ = ioError (userError (nm ++ ": Unmarshalling unions by value is not supported yet."))
+\end{code}
+
+Ptr marshallers:
+
+\begin{code}
+marshallPointer :: Ptr a -> IO (Ptr a)
+marshallPointer p = return p
+
+unmarshallPointer :: Ptr a -> IO (Ptr a)
+unmarshallPointer ptr = return ptr --makeNoFreePtr ptr
+
+writePointer :: Ptr (Ptr a) -> Ptr a -> IO ()
+writePointer = poke
+
+readPointer :: Ptr (Ptr a) -> IO (Ptr a)
+readPointer ptr = peek ptr
+
+sizeofPtr :: Word32
+sizeofPtr  = fromIntegral (sizeOf (undefined :: Foreign.Ptr.Ptr ()))
+\end{code}
+
+\begin{code}
+primInvokeIt :: (Ptr b -> Ptr a -> IO c) -> Int -> IO (Ptr a) -> IO c
+primInvokeIt meth offset mk_obj_ptr = do
+  obj_ptr <- mk_obj_ptr 
+  lpVtbl  <- derefPtr (castPtr obj_ptr)
+  methPtr <- indexPtr lpVtbl offset
+  meth methPtr obj_ptr
+
+primInvokeItFO :: (Ptr b -> Ptr a -> IO c) -> Int -> IO (ForeignPtr a) -> IO c
+primInvokeItFO meth offset mk_obj_ptr = do
+  obj_ptr <- mk_obj_ptr
+  lpVtbl  <- peek (foreignPtrToPtr (castForeignPtr obj_ptr))
+  methPtr <- indexPtr lpVtbl offset
+  withForeignPtr obj_ptr (\ optr -> meth methPtr optr)
+\end{code}
+
+\begin{code}
+stackStringLen :: Int -> String -> (Ptr String -> IO a) -> IO a
+stackStringLen len str f
+      = let slen = length str + 1 `max` len
+        in stackFrame (fromIntegral slen) $ \pstr -> do 
+	 writeString False pstr str
+         f pstr
+
+\end{code}
+
+\begin{code}
+{- BEGIN_GHC_ONLY
+
+enumToFlag :: Enum a => a -> Int
+enumToFlag tg = fromIntegral ((1::Word32) `shiftL` enumToInt tg)
+
+enumToInt :: Enum a => a -> Int
+enumToInt tg = I# (getTag tg)
+
+flagToIntTag :: Int -> Int
+flagToIntTag f | f < 0     = error "flagToIntTag: negative tag"
+               | otherwise = go 0 f
+   -- could've used Prelude.logBase, but don't need the precision it offers.
+ where
+    go n 0 = n
+    go n 1 = n + 1
+    go n x = go (n + 1) (x `div` 2)
+
+unboxInt :: Int -> Int#
+unboxInt (I# x#) = x#
+
+toIntFlag :: Int -> Int -> Int
+toIntFlag b v = fromIntegral ((1::Word32) `shiftL` (v + flagToIntTag b))
+
+   END_GHC_ONLY -}
+
+pow2Series :: Int -> Int32 -> [Int32]
+pow2Series len start = take len (iterate double start)
+ where
+   double x
+     | x == 0    = 1
+     | otherwise = 2*x
+
+orList :: [Int] -> Int
+orList ls = fromIntegral (foldl (\ acc x -> (fromIntegral x) .|. acc) (0::Int32) ls)
+
+orFlags :: (Num a,Flags a) => [a] -> a
+orFlags ls = foldl (.+.) 0 ls
+
+class Flags a where
+  (.+.) :: a -> a -> a
+
+\end{code}
+ lib/Makefile view
@@ -0,0 +1,201 @@+#
+# Makefile for basic HDirect support library.
+#
+TOP = ..
+include $(TOP)/mk/boilerplate.mk
+
+all ::
+
+PACKAGE=hdirect
+PACKAGE_DEPS=lang
+
+#
+# Should you want to build the library as a DLL, set it to NO.
+# (not supported with ghc-5.xx)
+#
+BUILD_STATICALLY=YES
+
+HC_OPTS += -package-name hdirect
+# Since we are using FFI exts we have to compile through C.
+HC_OPTS	+= -fglasgow-exts -fvia-C -Wall -fno-warn-deprecations 
+HC_OPTS	+= -package lang
+ifeq "$(BUILD_STATICALLY)" "YES"
+HC_OPTS += -static
+endif
+
+cpp_opts = -cpp -DBEGIN_GHC_ONLY='-}' -DEND_GHC_ONLY='{-' -DBEGIN_NOT_FOR_GHC='{-' -DEND_NOT_FOR_GHC='-}' -DELSE_FOR_GHC='-}-}' 
+
+HDirect_HC_OPTS      += $(cpp_opts)
+WideString_HC_OPTS   += $(cpp_opts)
+Pointer_HC_OPTS      += $(cpp_opts)
+SRC_MKDEPENDHS_OPTS  += $(cpp_opts)
+
+
+WideString_HC_OPTS  += -monly-3-regs
+SRC_IHC_OPTS        += -fno-qualified-names 
+HUGS_IHC_OPTS        = $(IHC_OPTS) --hugs -odir $(HUGSDIR)
+
+WideString_IHC_OPTS  += -fno-imports -fno-export-lists -fkeep-hresult -fout-pointers-are-not-refs
+PointerPrim_IHC_OPTS += -fkeep-hresult -fout-pointers-are-not-refs
+
+SRC_CC_OPTS += -I.
+
+IDL_SRCS = PointerPrim.idl WideString.idl
+HUGS_IDL_SRCS += $(IDL_SRCS)
+IDL_HS_SRCS = $(patsubst %.idl, %.hs, $(IDL_SRCS))
+
+# Files that are part of both COM and non-COM builds.
+C_SRCS  = PointerSrc.c WideStringSrc.c
+H_SRCS  = HDirect.h PointerSrc.h WideStringSrc.h
+HS_SRCS = Pointer.lhs HDirect.lhs $(IDL_HS_SRCS)
+
+# for adding to SRC_DIST_FILES
+HUGS_EXTRA_SRCS =
+
+#
+# The Hugs98 version of the library is deposited in a separate directory, so
+# that it can coexist with the GHC version.
+#
+HUGSDIR=hugs
+
+SRCS = $(HS_SRCS) $(C_SRCS)
+
+SRC_DIST_FILES  = $(SRCS) $(H_SRCS) $(HUGS_IDL_SRCS) $(HUGS_EXTRA_SRCS) Makefile hdirect.pkg
+CLEAN_FILES += $(patsubst %.idl,%.hs,$(wildcard *.idl))
+
+#
+# 'make install' setup:
+#
+INSTALL_DATAS	= hdirect.pkg $(HS_IFACES)
+INSTALL_LIBS    = libHShdirect$(_way).a $(HUGS_FILES)
+
+ifeq "$(BUILD_STATICALLY)" "NO"
+INSTALL_PROGS   += HShdirect.dll
+INSTALL_LIBS    += libHShdirect_imp.a
+endif
+
+ifeq "$(STANDALONE_DIST)" "YES"
+all :: libHShdirect$(_way).a HShdirect.$(way_)o
+endif
+
+# We put the generated output for Hugs98 in a separate directory, $(HUGSDIR), so that
+# GHC and Hugs builds can coexist.
+all :: 
+	@if [ -d $(HUGSDIR) ]; then : ; else mkdir $(HUGSDIR); fi;
+
+clean :: 	
+	if [ -d $(HUGSDIR) ]; then $(RM) -rf $(HUGSDIR)/ ; else : ; fi;
+
+HUGS_FILES = Pointer.lhs HDirect.lhs $(patsubst %.idl, $(HUGSDIR)/%.hs, $(HUGS_IDL_SRCS)) $(patsubst %.idl, $(HUGSDIR)/%.$(dllext), $(HUGS_IDL_SRCS))
+
+all :: $(HUGS_FILES)
+
+all :: dlls
+
+C_STUBS = $(patsubst %.idl, $(HUGSDIR)/%.c, $(IDL_SRCS))
+
+$(HUGSDIR)/%.hs: %.idl
+	$(IHC) $(HUGS_IHC_OPTS) -c $< -o $@
+
+$(HUGSDIR)/%.c: $(HUGSDIR)/%.hs
+	@:
+
+$(HUGSDIR)/%.$(STUB_OBJ_SUFFIX) : %.c
+	@$(RM) $@
+	$(CC) $(CC_OPTS) -c $< -o $@
+
+$(HUGSDIR)/%.$(STUB_OBJ_SUFFIX) : $(HUGSDIR)/%.c
+	@$(RM) $@
+	$(CC) $(CC_OPTS) -c $< -o $@
+
+ifeq "$(USE_MSVC_TOOLS)" "YES"
+$(HUGSDIR)/%.obj : %.c
+	@$(RM) $@
+	$(CCDLL) $(CCDLL_OPTS) -c $< -Fo$@
+$(HUGSDIR)/%.obj : $(HUGSDIR)/%.c
+	@$(RM) $@
+	$(CCDLL) $(CCDLL_OPTS) -c $< -Fo$@
+endif
+
+.PRECIOUS: $(HUGSDIR)/%.$(STUB_OBJ_SUFFIX) $(HUGSDIR)/%.c $(HUGSDIR)/%.hs
+
+HugsMod.def :
+	@echo EXPORTS     > $@
+	@echo initModule >> $@
+
+$(HUGSDIR)/%.$(dllext) : $(HUGSDIR)/%.$(STUB_OBJ_SUFFIX)
+	$(CCDLL) $(CCDLL_OPTS) -o $@ $^ $(CCDLL_LIBS)
+
+dlls :: $(patsubst %.c, %.$(dllext), $(C_STUBS))
+
+all :: $(HUGSDIR)/HDirect.lhs $(HUGSDIR)/Pointer.lhs
+
+$(HUGSDIR)/HDirect.lhs : HDirect.lhs
+	$(CP) $^ $@
+$(HUGSDIR)/Pointer.lhs : Pointer.lhs
+	$(CP) $^ $@
+
+# Configuration of hugslibdir is for local testing only; remove before releasing.
+ifeq "$(hugslibdir)" ""
+hugslibdir=c:/src/hugs98/lib
+endif
+
+install-hugs ::
+	mkdir -p $(hugslibdir)/hdirect
+	cp $(HUGSDIR)/*.$(dllext) $(hugslibdir)/hdirect
+	cp $(HUGSDIR)/*.hs $(hugslibdir)/hdirect
+	cp *.lhs $(hugslibdir)/hdirect
+
+# End of Hugs specific bit
+
+ifeq "$(STANDALONE_DIST)" "YES"
+libHShdirect$(_way).a : $(OBJS)
+	$(AR) $(AR_OPTS) $@ $^
+
+HShdirect.$(way_)o: $(OBJS)
+	$(LD) -r $(LD_X) -o $@ $(OBJS)
+endif
+
+ifeq "$(BUILD_STATICALLY)" "NO"
+dll ::
+	$(HC) --mk-dll -o HShdirect.dll libHShdirect.a -fglasgow-exts -package lang -lwinmm -luser32
+endif
+
+boot :: $(IDL_HS_SRCS)
+
+include $(TOP)/mk/target.mk
+
+ifneq "$(BUILD_STATICALLY)" "YES"
+all :: dll
+endif
+
+ifeq "$(FOR_WIN32)" "YES"
+HDIRECT_LIBDIR=$(shell cygpath -p -w `pwd` | sed -e 's%\\%/%g')
+else
+HDIRECT_LIBDIR=$(shell pwd)
+endif
+
+ifeq "$(GHC_PKG)" ""
+GHC_PKG=ghc-pkg
+endif
+
+install-pkg: hdirect.pkg
+	@hd_libdir="$(HDIRECT_LIBDIR)" $(GHC_PKG) -u < hdirect.pkg || (echo "Unable to install 'hdirect' package for GHC - perhaps GHC isn't installed."; echo "Try running ghc-pkg utility \"ghc-pkg -u < $(datadir)/hdirect.pkg\""; echo "when GHC is installed.")
+
+# extra dependencies for Hugs bits.
+$(HUGSDIR)/PointerPrim.c : $(HUGSDIR)/PointerPrim.hs
+$(HUGSDIR)/PointerPrim.$(STUB_OBJ_SUFFIX) : $(HUGSDIR)/PointerPrim.c
+
+$(HUGSDIR)/WideString.c : $(HUGSDIR)/WideString.hs
+$(HUGSDIR)/WideString.$(STUB_OBJ_SUFFIX) : $(HUGSDIR)/WideString.c
+
+$(HUGSDIR)/WideString.$(dllext) : $(HUGSDIR)/WideString.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/WideString.$(dllext) : $(HUGSDIR)/WideStringSrc.$(STUB_OBJ_SUFFIX)
+
+$(HUGSDIR)/PointerPrim.$(dllext) : $(HUGSDIR)/PointerPrim.$(STUB_OBJ_SUFFIX)
+$(HUGSDIR)/PointerPrim.$(dllext) : $(HUGSDIR)/PointerSrc.$(STUB_OBJ_SUFFIX)
+
+ifeq "$(FOR_WIN32)" "YES"
+$(HUGSDIR)/WideString.$(dllext) : HugsMod.def
+$(HUGSDIR)/PointerPrim.$(dllext) : HugsMod.def
+endif
+ lib/Pointer.lhs view
@@ -0,0 +1,155 @@+
+Copyright (c) 1998,  Daan Leijen, leijen@@fwi.uva.nl
+
+This module is part of HaskellDirect (H/Direct).
+
+\begin{code}
+{-# OPTIONS -#include "PointerSrc.h" #-}
+module Pointer  
+	( 
+	  Ptr
+	
+	, allocMemory
+	, stackFrame
+
+	, writeSeqAtDec
+{-
+	, ptrInc
+	, writeSeqAt
+-}
+
+        , freeMemory
+	, freeBSTR
+	, freeWith
+	, freeWithC
+	
+	, primNoFree
+	
+	, finalNoFree
+	, finalFreeMemory
+	
+	, makeFO
+
+       ) where
+
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import PointerPrim
+import Word     ( Word32 )
+import Monad
+\end{code}
+
+The Pointer module provides helper functions over Ptrs +
+allocation/freeing of memory via malloc/free or the COM task
+allocator.
+
+\begin{code}
+type Finalizer a  = Ptr a -> IO ()
+
+makeFO :: Ptr a -> FunPtr (Ptr a -> IO ()) -> IO (ForeignPtr b)
+{- BEGIN_GHC_ONLY 
+#if __GLASGOW_HASKELL__ > 601
+makeFO obj finaliser = newForeignPtr (mkFinal finaliser obj) obj >>= return.castForeignPtr
+#else
+makeFO obj finaliser = newForeignPtr obj (mkFinal finaliser obj) >>= return.castForeignPtr
+#endif
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+-- Versionitis. If your version of Hugs is troubled by this one, simply enable the other version.
+makeFO obj finaliser = newForeignPtr (mkFinal finaliser obj) obj >>= return.castForeignPtr
+--makeFO obj finaliser = newForeignPtr obj (mkFinal finaliser obj) >>= return.castForeignPtr
+{- END_NOT_FOR_GHC -}
+
+{- BEGIN_GHC_ONLY
+#if __GLASGOW_HASKELL__ < 505
+mkFinal final obj = ap0 final obj
+foreign import ccall "dynamic" ap0 :: FunPtr (Ptr a -> IO()) -> (Ptr a -> IO ())
+#else
+mkFinal final _ = final
+#endif
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+mkFinal final _ = final
+{- END_NOT_FOR_GHC -}
+
+\end{code}
+
+Helpers.
+
+\begin{code}
+writeSeqAtDec :: Word32 -> [Ptr a -> IO ()] -> Ptr a -> IO ()
+writeSeqAtDec size ws ptr = go init_ptr ws
+  where
+   len           = fromIntegral (length ws - 1)
+   init_ptr      = ptr `plusPtr` (size_i * len)
+   size_i        = fromIntegral size
+
+   go _   []     = return ()
+   go ptr (x:xs) = do
+      x ptr
+      let ptr_next = ptr `plusPtr` (-size_i)
+      go ptr_next xs
+
+{-
+ptrInc i p        = p `plusAddr` (fromIntegral i)
+ptrDec d p        = p `plusAddr` (-(fromIntegral  d))
+
+writeSeqAt :: Word32 -> [Ptr a -> IO ()] -> Ptr a -> IO ()
+writeSeqAt size ws ptr = go ptr ws
+ where
+   go ptr []     = return ()
+   go ptr (x:xs) = do
+      x ptr
+      let ptr_next = ptrInc size ptr
+      go ptr_next xs
+-}
+
+\end{code}
+
+Use @stackFrame@ when you know the allocated chunk have
+a fixed extent.
+
+\begin{code}
+stackFrame :: Word32 -> (Ptr a -> IO b) -> IO b
+stackFrame size f
+      = do p <- allocMemory size
+           f p `always` primFreeMemory (castPtr p)
+
+\end{code}
+
+Special free routines for pointers. Use them to manually free pointers.
+
+\begin{code}
+freeMemory            = freeWithC primFreeMemory
+freeBSTR              = freeWithC primFreeBSTR
+
+freeWithC :: Finalizer () -> Ptr a -> IO ()
+freeWithC final p = final (castPtr p)
+
+freeWith :: (Ptr a -> IO ()) -> Ptr a -> IO ()
+freeWith free p = free p 
+\end{code}
+
+Helper functions that doesn't really have a good home to go to:
+
+\begin{code}
+always :: IO a -> IO () -> IO a
+always io action
+      = do x <- io `catch` (\ err -> do { action; ioError err })
+           action
+           return x
+
+\end{code}
+
+Primitives/helpers:
+
+\begin{code}
+allocMemory :: Word32 -> IO (Ptr a)
+allocMemory sz = do
+  a <- primAllocMemory sz
+  if a == nullPtr then
+     ioError (userError "allocMemory: not enough memory")
+   else
+     return (castPtr a)
+
+\end{code}
+ lib/PointerPrim.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS -#include "PointerSrc.h" #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+-- Automatically generated by HaskellDirect (ihc.exe), version 0.20
+-- Created: 16:37 Pacific Standard Time, Thursday 18 December, 2003
+-- Command line: -fno-qualified-names -fkeep-hresult -fout-pointers-are-not-refs -c PointerPrim.idl -o PointerPrim.hs
+
+module PointerPrim
+       ( primNoFree
+       , primFreeBSTR
+       , primFreeMemory
+       , finalNoFree
+       , finalFreeMemory
+       , primAllocMemory
+       , primFinalise
+       ) where
+       
+import Prelude
+import Foreign.Ptr (Ptr)
+import System.IO.Unsafe (unsafePerformIO)
+import Word (Word32)
+
+primNoFree :: Ptr ()
+           -> IO ()
+primNoFree p =
+  prim_PointerPrim_primNoFree p
+
+foreign import ccall "primNoFree" prim_PointerPrim_primNoFree :: Ptr () -> IO ()
+primFreeBSTR :: Ptr ()
+             -> IO ()
+primFreeBSTR p =
+  prim_PointerPrim_primFreeBSTR p
+
+foreign import ccall "primFreeBSTR" prim_PointerPrim_primFreeBSTR :: Ptr () -> IO ()
+primFreeMemory :: Ptr ()
+               -> IO ()
+primFreeMemory p =
+  prim_PointerPrim_primFreeMemory p
+
+foreign import ccall "primFreeMemory" prim_PointerPrim_primFreeMemory :: Ptr () -> IO ()
+finalNoFree :: Ptr ()
+finalNoFree = unsafePerformIO (prim_PointerPrim_finalNoFree)
+
+foreign import ccall "finalNoFree" prim_PointerPrim_finalNoFree :: IO (Ptr ())
+finalFreeMemory :: Ptr ()
+finalFreeMemory =
+  unsafePerformIO (prim_PointerPrim_finalFreeMemory)
+
+foreign import ccall "finalFreeMemory" prim_PointerPrim_finalFreeMemory :: IO (Ptr ())
+primAllocMemory :: Word32
+                -> IO (Ptr ())
+primAllocMemory sz = prim_PointerPrim_primAllocMemory sz
+
+foreign import ccall "primAllocMemory" prim_PointerPrim_primAllocMemory :: Word32 -> IO (Ptr ())
+primFinalise :: Ptr ()
+             -> Ptr ()
+             -> IO ()
+primFinalise finaliser finalisee =
+  prim_PointerPrim_primFinalise finaliser
+                                finalisee
+
+foreign import ccall "primFinalise" prim_PointerPrim_primFinalise :: Ptr () -> Ptr () -> IO ()
+
+ lib/PointerPrim.idl view
@@ -0,0 +1,21 @@+/*
+  Primitive pointer allocation/freeing 
+  functions.
+ */
+stub_include("PointerSrc.h");
+module PointerPrim {
+
+void primNoFree ([in,ptr]void* p);
+void primFreeBSTR ([in,ptr]void* p);
+void primFreeMemory ([in,ptr]void* p);
+
+[pure]void* finalNoFree();
+[pure]void* finalFreeMemory();
+
+[ptr]void* primAllocMemory([in]unsigned int sz);
+
+void  primFinalise( [in,ptr]void* finaliser
+		  , [in,ptr]void* finalisee);
+
+};
+
+ lib/PointerSrc.c view
@@ -0,0 +1,149 @@+/* This stuff will eventually be replaced by calls to the
+   storage manager in the new GHC/Hugs RTS.   -- sof
+*/
+
+#if defined(__CYGWIN32__) || defined(__MINGW32__) || defined(__CYGWIN__)
+#define __BASTARDIZED_WIN32__ 1
+#endif
+
+/*-----------------------------------------------------------
+-- (c) 1998,  Daan Leijen, leijen@@fwi.uva.nl
+-----------------------------------------------------------*/
+/* #define DEBUG */
+
+/* if you don't use COM, comment this out */
+/* (pass the setting for this via command line instead.) */
+/* #define COM */
+
+/* define the DLL export macro */
+#if defined(_BASTARDIZED_WIN32__)
+#define DLLEXPORT(res)  __declspec(dllexport) res
+#else
+/* redef this default for your system */
+#define DLLEXPORT(res)  extern res
+#endif
+
+
+#ifdef COM
+#define COBJMACROS
+#define CINTERFACE
+#endif
+
+#include <stdio.h>
+
+#if !defined(__BASTARDIZED_WIN32__) && defined(COM)
+#include <windows.h>
+#else
+# if defined(__BASTARDIZED_WIN32__)
+  #include <windows.h>
+# if defined(__BASTARDIZED_WIN32__) && defined(COM)
+  #include "comPrim.h"
+# endif
+# endif
+#include <stdlib.h>
+#endif
+
+#ifdef DEBUG
+static int nallocs = 0;
+static int nallocs_ = 0;
+#endif
+
+void primPointerCheck(void)
+{
+#ifdef DEBUG
+    if (nallocs - nallocs_ != 0)
+      printf( "pointer errors: allocs - frees = %i\n", nallocs - nallocs_ );
+    nallocs_ = nallocs;
+#endif    
+}     
+
+/*-----------------------------------------------------------
+-- Free routines for foreign objects
+-----------------------------------------------------------*/
+
+DLLEXPORT(void) primFreeBSTR( void* p )
+{
+#ifdef COM
+   if (p) SysFreeString( (BSTR)p );
+#endif
+}
+
+DLLEXPORT(void) primNoFree( void* p )
+{
+#if 0
+ char    msg[200];
+ WCHAR* wmsg;
+ HRESULT hr;
+
+ sprintf(msg, "freeing: %p", p);
+ MessageBox(NULL, msg, "primNoFree", MB_OK );
+
+ hr = primGUIDToString(p, &wmsg);
+ if (SUCCEEDED(hr)) {
+    MessageBoxW(NULL, wmsg, L"primNoFree-clsid", MB_OK);
+ }
+#endif
+}
+
+void primFinalise (void* f, void* a)
+{ ((void (*)(void *))f)(a); } 
+
+
+/*-----------------------------------------------------------
+-- Memory allocation
+-----------------------------------------------------------*/
+
+DLLEXPORT(void*) primAllocMemory( int size )
+{
+#ifdef COM
+
+#ifdef DEBUG
+    void* p;
+    p = CoTaskMemAlloc( size );
+    printf("alloc: %p, size = %i\n", p, size );
+    if (p) nallocs++;
+    return p;
+#else
+    return CoTaskMemAlloc(size);
+#endif
+
+#else
+    return malloc(size);
+#endif
+}
+
+/* COM version of freeing */
+#ifdef COM
+DLLEXPORT(void) primFreeMemory( void* p )
+{
+ #ifdef DEBUG    
+   if (!p) printf( "freeing null pointer\n" );
+ #endif
+   if (!p) return;
+ #ifdef DEBUG
+   if (p) nallocs--;
+   printf( "free: %p\n", p);
+ #endif
+   CoTaskMemFree( p );
+}
+#endif
+
+#ifndef COM
+DLLEXPORT(void) primFreeMemory( void* p )
+{
+ #ifdef DEBUG    
+   if (!p) printf( "free null pointer\n" );
+ #endif
+
+   if (!p) return;
+
+   free(p);
+}
+#endif /* !COM */
+
+/* Strictly speaking, converting a function pointer to a void*
+   is not guaranteed to be information preserving in ANSI C.
+*/
+void* finalFreeMemory() { return (void*)&primFreeMemory; }
+void* finalNoFree()     { return (void*)&primNoFree;   }
+void* finalFreeBSTR()   { return (void*)&primFreeBSTR; }
+ lib/PointerSrc.h view
@@ -0,0 +1,15 @@+#ifndef __POINTERSRC_H__
+#define __POINTERSRC_H__
+
+extern void   primPointerCheck();
+extern void   primNoFree(void* p);
+extern void   primFinalise(void* f, void* a);
+extern void*  primAllocMemory(int size);
+extern void   primFreeMemory(void* p);
+extern void   primFreeBSTR(void* p);
+extern void*  finalFreeMemory();
+extern void*  finalFreeBSTR();
+extern void*  finalFreeObject();
+extern void*  finalNoFree();
+
+#endif /* __POINTERSRC_H__ */
+ lib/WideString.hs view
@@ -0,0 +1,153 @@+{-# OPTIONS -#include <stdlib.h> #-}
+{-# OPTIONS -#include "WideStringSrc.h" #-}
+{-# OPTIONS -#include "PointerSrc.h" #-}
+-- Automatically generated by HaskellDirect (ihc.exe), version 0.20
+-- Created: 16:38 Pacific Standard Time, Thursday 18 December, 2003
+-- Command line: -fno-qualified-names -fno-imports -fno-export-lists -fkeep-hresult -fout-pointers-are-not-refs -c WideString.idl -o WideString.hs
+
+module WideString where
+
+
+
+import PointerPrim
+import Pointer
+import Foreign.Ptr
+import HDirect
+import Word         ( Word32 )
+import Int
+import IOExts
+
+type LPWSTR = WideString
+type LPCWSTR = WideString
+
+newtype WideString = WideString (Ptr Wchar_t)
+
+lengthWideString :: WideString -> Int
+lengthWideString (WideString ws) = unsafePerformIO (lenWideString ws >>= return . fromIntegral)
+
+stackWideString :: String -> (Ptr Wchar_t -> IO a) -> IO a
+stackWideString str wcont = do
+    stackString str $ \ len pstr -> do
+    let wlen = wideStringLen pstr
+    stackFrame (sizeofWideString*(wlen+1)) $ \ pwide -> do
+    primStringToWide pstr (fromIntegral len) pwide wlen 
+    wcont pwide
+
+mkWideString :: String -> WideString
+mkWideString ls = unsafePerformIO (stringToWide ls)
+
+stringToWide :: String -> IO WideString
+stringToWide str =
+  stackString str $ \ len pstr -> do
+  let wlen = wideStringLen pstr
+   -- Note: we're using the task allocator here.
+  pwide <- primAllocMemory ((wlen + 1) * sizeofWideString)
+  primStringToWide pstr (fromIntegral len) (castPtr pwide) wlen
+  unmarshallWideString (castPtr pwide)
+
+-- Sometimes a (wchar_t*) double up as holding a 16-bit (yep, no kidding) -
+-- higher 16 bits have to be zero, lower 16 the val. We *love* this stuff.
+word16ToWideString :: Word16 -> IO WideString
+word16ToWideString w = 
+  return (WideString (plusPtr nullPtr (fromIntegral w)))
+
+nullWideString :: WideString
+nullWideString = WideString (nullPtr)
+
+-- Does not belong here - at all.
+
+stackString :: String -> (Int -> Ptr Char -> IO a) -> IO a
+stackString str pcont = do
+   let len = 1 + fromIntegral (length str)
+   stackFrame len $ \ ptr -> do
+   writeString False ptr str
+   pcont (fromIntegral len) (castPtr ptr)
+
+marshallWideString :: WideString -> IO (Ptr WideString)
+marshallWideString (WideString ptr) = marshallPointer ptr >>= return.castPtr
+
+marshallWideString2 :: String -> IO (Ptr WideString)
+marshallWideString2 str = do
+  wstr <- stringToWide str
+  marshallWideString wstr
+
+-- using 'Ptr a' is too weak, really - but avoids trivial
+-- problems wrt WideString/Wchar_t confusion. ToDo: tidy up.
+unmarshallWideString :: Ptr a -> IO WideString
+unmarshallWideString ptr = do
+  po <- unmarshallPointer ptr
+  return (WideString (castPtr po))
+
+unmarshallWideString2 :: Ptr a -> IO String
+unmarshallWideString2 ptr = do
+  po <- unmarshallPointer ptr
+  wideToStr (WideString (castPtr po))
+
+-- writeWideString doesn't copy the wide string, it merely
+-- fills in a pointer to the wide string.
+
+writeWideString :: Ptr WideString -> WideString -> IO ()
+writeWideString ptr (WideString pstr) = writePointer (castPtr ptr) pstr
+
+writeWideString2 :: Ptr WideString -> String -> IO ()
+writeWideString2 ptr str = do
+   pwstr <- marshallWideString2 str
+   writePointer (castPtr ptr) pwstr
+
+-- is this correct?
+readWideString :: Ptr WideString -> IO WideString
+readWideString p = unmarshallWideString (castPtr p)
+
+readWideString2 :: Ptr WideString -> IO String
+readWideString2 p = unmarshallWideString2 (castPtr p)
+
+freeWideString :: Ptr WideString -> IO ()
+freeWideString _ = return () --(WideString pstr) = freeMemory pstr
+
+freeWString :: WideString -> IO ()
+freeWString (WideString pstr) = freeMemory pstr
+
+sizeofWideString :: Word32
+sizeofWideString = 2  -- not set in stone.
+
+wideToStr :: WideString -> IO String
+wideToStr wide = do
+   pwide     <- marshallWideString wide
+   (pstr,hr) <- wideToString (castPtr pwide)
+   unmarshallString (castPtr pstr)
+
+
+wideStringLen :: Ptr Char
+              -> Word32
+wideStringLen str =
+  unsafePerformIO (prim_WideString_wideStringLen str)
+
+foreign import stdcall "wideStringLen" prim_WideString_wideStringLen :: Ptr Char -> IO Word32
+wideToString :: Ptr Wchar_t
+             -> IO (Ptr Char, Int32)
+wideToString wstr =
+  do
+    pstr <- allocBytes (fromIntegral sizeofPtr)
+    o_wideToString <- prim_WideString_wideToString wstr pstr
+    pstr <- doThenFree free readPtr pstr
+    return (pstr, o_wideToString)
+
+foreign import stdcall "wideToString" prim_WideString_wideToString :: Ptr Word16 -> Ptr (Ptr Char) -> IO Int32
+lenWideString :: Ptr Wchar_t
+              -> IO Int32
+lenWideString wstr = prim_WideString_lenWideString wstr
+
+foreign import stdcall "lenWideString" prim_WideString_lenWideString :: Ptr Word16 -> IO Int32
+primStringToWide :: Ptr Char
+                 -> Word32
+                 -> Ptr Wchar_t
+                 -> Word32
+                 -> IO Int32
+primStringToWide str len wstr wlen =
+  prim_WideString_primStringToWide str
+                                   len
+                                   wstr
+                                   wlen
+
+foreign import stdcall "primStringToWide" prim_WideString_primStringToWide :: Ptr Char -> Word32 -> Ptr Word16 -> Word32 -> IO Int32
+
+ lib/WideString.idl view
@@ -0,0 +1,131 @@+stub_include <stdlib.h>;
+stub_include("WideStringSrc.h");
+stub_include("PointerSrc.h");
+[pointer_default(ptr)]
+module WideString {
+
+
+hs_quote("
+import PointerPrim
+import Pointer
+import Foreign.Ptr
+import HDirect
+import Word         ( Word32 )
+import Int
+import IOExts
+
+type LPWSTR = WideString
+type LPCWSTR = WideString
+
+newtype WideString = WideString (Ptr Wchar_t)
+
+lengthWideString :: WideString -> Int
+lengthWideString (WideString ws) = unsafePerformIO (lenWideString ws >>= return . fromIntegral)
+
+stackWideString :: String -> (Ptr Wchar_t -> IO a) -> IO a
+stackWideString str wcont = do
+    stackString str $ \ len pstr -> do
+    let wlen = wideStringLen pstr
+    stackFrame (sizeofWideString*(wlen+1)) $ \ pwide -> do
+    primStringToWide pstr (fromIntegral len) pwide wlen 
+    wcont pwide
+
+mkWideString :: String -> WideString
+mkWideString ls = unsafePerformIO (stringToWide ls)
+
+stringToWide :: String -> IO WideString
+stringToWide str =
+  stackString str $ \ len pstr -> do
+  let wlen = wideStringLen pstr
+   -- Note: we're using the task allocator here.
+  pwide <- primAllocMemory ((wlen + 1) * sizeofWideString)
+  primStringToWide pstr (fromIntegral len) (castPtr pwide) wlen
+  unmarshallWideString (castPtr pwide)
+
+-- Sometimes a (wchar_t*) double up as holding a 16-bit (yep, no kidding) -
+-- higher 16 bits have to be zero, lower 16 the val. We *love* this stuff.
+word16ToWideString :: Word16 -> IO WideString
+word16ToWideString w = 
+  return (WideString (plusPtr nullPtr (fromIntegral w)))
+
+nullWideString :: WideString
+nullWideString = WideString (nullPtr)
+
+-- Does not belong here - at all.
+
+stackString :: String -> (Int -> Ptr Char -> IO a) -> IO a
+stackString str pcont = do
+   let len = 1 + fromIntegral (length str)
+   stackFrame len $ \ ptr -> do
+   writeString False ptr str
+   pcont (fromIntegral len) (castPtr ptr)
+
+marshallWideString :: WideString -> IO (Ptr WideString)
+marshallWideString (WideString ptr) = marshallPointer ptr >>= return.castPtr
+
+marshallWideString2 :: String -> IO (Ptr WideString)
+marshallWideString2 str = do
+  wstr <- stringToWide str
+  marshallWideString wstr
+
+-- using 'Ptr a' is too weak, really - but avoids trivial
+-- problems wrt WideString/Wchar_t confusion. ToDo: tidy up.
+unmarshallWideString :: Ptr a -> IO WideString
+unmarshallWideString ptr = do
+  po <- unmarshallPointer ptr
+  return (WideString (castPtr po))
+
+unmarshallWideString2 :: Ptr a -> IO String
+unmarshallWideString2 ptr = do
+  po <- unmarshallPointer ptr
+  wideToStr (WideString (castPtr po))
+
+-- writeWideString doesn't copy the wide string, it merely
+-- fills in a pointer to the wide string.
+
+writeWideString :: Ptr WideString -> WideString -> IO ()
+writeWideString ptr (WideString pstr) = writePointer (castPtr ptr) pstr
+
+writeWideString2 :: Ptr WideString -> String -> IO ()
+writeWideString2 ptr str = do
+   pwstr <- marshallWideString2 str
+   writePointer (castPtr ptr) pwstr
+
+-- is this correct?
+readWideString :: Ptr WideString -> IO WideString
+readWideString p = unmarshallWideString (castPtr p)
+
+readWideString2 :: Ptr WideString -> IO String
+readWideString2 p = unmarshallWideString2 (castPtr p)
+
+freeWideString :: Ptr WideString -> IO ()
+freeWideString _ = return () --(WideString pstr) = freeMemory pstr
+
+freeWString :: WideString -> IO ()
+freeWString (WideString pstr) = freeMemory pstr
+
+sizeofWideString :: Word32
+sizeofWideString = 2  -- not set in stone.
+
+wideToStr :: WideString -> IO String
+wideToStr wide = do
+   pwide     <- marshallWideString wide
+   (pstr,hr) <- wideToString (castPtr pwide)
+   unmarshallString (castPtr pstr)
+
+");
+
+[pure]
+unsigned int wideStringLen([in,ptr]char* str);
+int wideToString ( [in,ptr]wchar_t* wstr
+		 , [out,ref]char** pstr
+		 );
+int lenWideString ( [in,ptr]wchar_t* wstr );
+
+int primStringToWide( [in,ptr]char* str
+		    , [in]unsigned int len
+		    , [in,ptr]wchar_t* wstr
+		    , [in]unsigned int wlen
+		    );
+
+};
+ lib/WideStringSrc.c view
@@ -0,0 +1,177 @@+/* define the DLL export macro */
+#if defined(_WIN32) && !defined(__CYGWIN32__)
+#define DLLEXPORT(res)  __declspec(dllexport) res
+#else
+/* redef this default for your system */
+#define DLLEXPORT(res)  extern res
+#endif
+
+
+#ifdef COM
+#define COBJMACROS
+#define CINTERFACE
+#endif
+
+#include <stdio.h>
+
+#if defined(_WIN32) && !defined(__CYGWIN32__)
+#include <windows.h>
+#define WCHAR wchar_t
+#else
+ #ifdef __CYGWIN32__
+  #include <windows.h>
+ #endif
+#include <stdlib.h>
+#define WCHAR wchar_t
+#endif
+
+#include "WideStringSrc.h"
+
+#ifdef COM
+#include "comPrim.h"
+#else
+#define UNI2STR(regstr, unistr) wcstombs (regstr, unistr, wcslen (unistr)+1)
+#endif
+
+/* wcslen() substitute implementation for cygwin'ers. */
+#if defined(__CYGWIN32__) || defined(__CYGWIN__)
+
+/* Troublesome to use the one that comes with 20.1 of cygwin */
+#ifdef MB_CUR_MAX
+#undef MB_CUR_MAX
+#endif
+#define MB_CUR_MAX 2
+
+static int wcslen(WCHAR* wstr)
+{
+  char str[MB_CUR_MAX];
+  char msg[80];
+  WCHAR* wptr;
+  int nbytes, i = 0;
+  
+  wptr = wstr;
+
+  if ( wptr == NULL )
+     return 0;
+
+  while ( *wptr != L'\0' ) {
+     nbytes = wctomb ( str, *wptr );
+     i += nbytes; (char*)wptr += nbytes;
+  }
+  return i;
+}
+#endif
+
+
+/* Return the length of a wide string big enough
+   to hold the multi-byte string.
+*/
+unsigned int wideStringLen (char* str)
+{
+#ifdef _WIN32
+  return MultiByteToWideChar(CP_ACP, 0, str, -1, NULL, 0);
+#else
+  /* Non Win32 specific version */
+  WCHAR foo[300];  // Ho-ho, bulletproof!
+  unsigned int len;
+
+  if (!str) {
+     return 0;
+  } else {
+     len = mbstowcs (foo, str, strlen(str));
+     return ( (len < 0) ? 0 : len);
+  }
+#endif
+}
+
+/* ToDo: sort out source code deps. and make
+   the return type HRESULT.
+*/
+int
+wideToString ( WCHAR* wstr, char** pstr )
+{
+  int len;
+  char* str;
+
+  if (!pstr) {
+#ifdef _WIN32
+    return E_FAIL;
+#else
+    return -1;
+#endif
+  }
+
+#if defined(_WIN32) && defined(COM)
+
+  /* Compute how big a buffer we need to allocate for
+     multi-byte string...
+  */
+  len = WideCharToMultiByte ( CP_ACP, 0, wstr, -1
+			    , NULL, 0, NULL, NULL);
+  if (len == 0) {
+    return E_FAIL;
+  }
+
+  /* 
+    Ask COM task allocator for some memory.
+   */
+  str = CoTaskMemAlloc(len * sizeof(char));
+  if (str == NULL) {
+    return E_FAIL;
+  }
+
+  WideCharToMultiByte(CP_ACP, 0, wstr, -1, str, len, NULL, NULL);
+  *pstr = str;
+  return S_OK;
+
+#else
+
+  len = wcslen(wstr);
+  str=(char*)malloc(len+1);
+  UNI2STR(str,wstr);
+  *pstr = str;
+  return 0;
+
+#endif
+}
+
+/* Converting (null-terminated) strings into wide/Unicode ones */
+int primStringToWide( char* str, unsigned int len, WCHAR* wstr , unsigned int wlen )
+{
+#ifdef _WIN32
+  return MultiByteToWideChar(CP_ACP, 0, str, len, wstr, wlen);
+#else
+  int l;
+
+  if ( wstr ) {
+    if ( !str ) {
+       *wstr = 0;
+       return 0;
+    } else {
+       l = mbstowcs (wstr, str, wlen+1);
+       return l;
+    }
+ } else {
+    return (-1);
+ }
+#endif
+}
+
+/* The proto might not be in scope, so you might
+   just get a warning from the C compiler.
+   
+   Reluctant to define the proto, as experience has
+   shown this to be troublesome (there appears to be no
+   universal agreement as to what the return type of
+   wcslen() is.)
+
+extern int wcslen (const WCHAR* wstr);
+extern size_t wcslen (const WCHAR* wstr);
+
+*/  
+
+int
+lenWideString (WCHAR* wstr )
+{
+  return wcslen(wstr);
+}
+ lib/WideStringSrc.h view
@@ -0,0 +1,26 @@+
+#ifndef __WIDESTRING_H__
+#define __WIDESTRING_H__
+
+#ifndef WCHAR
+#define WCHAR wchar_t
+#endif
+
+extern
+int
+primStringToWide ( char* str
+                 , unsigned int len
+		 , WCHAR* wstr
+		 , unsigned int wlen
+		 );
+extern
+int
+wideToString ( WCHAR* wstr, char** pstr );
+
+extern
+unsigned int wideStringLen (char* str);
+
+extern
+int lenWideString (WCHAR* str);
+
+#endif
+ lib/hdirect.pkg view
@@ -0,0 +1,12 @@+Package { name = "hdirect",
+          import_dirs  = ["${hd_libdir}"],
+          source_dirs  = [],
+          library_dirs = ["${hd_libdir}"],
+          hs_libraries = ["HShdirect"],
+          extra_libraries = [],
+          include_dirs = ["${hd_libdir}"],
+          c_includes = [],
+          package_deps = ["base", "haskell98", "lang"],
+          extra_ghc_opts = [],
+          extra_cc_opts = [],
+          extra_ld_opts = []}
+ mk/boilerplate.mk view
@@ -0,0 +1,53 @@+STANDALONE_DIST=YES
+#-----------------------------------------------------------------------------
+#
+#
+#-----------------------------------------------------------------------------
+
+# Begin by slurping in the boilerplate from one level up.
+# Remember, TOP is the top level of the innermost level
+# (FPTOOLS_TOP is the fptools top)
+
+# We need to set TOP to be the TOP that the next level up expects!
+# The TOP variable is reset after the inclusion of the fptools
+# boilerplate, so we stash TOP away first:
+ifneq "$(STANDALONE_DIST)" "YES"
+HDIRECT_TOP := $(TOP)
+TOP:=$(TOP)/..
+
+include $(TOP)/mk/boilerplate.mk
+
+# Reset TOP
+TOP:=$(HDIRECT_TOP)
+endif
+
+# Determine what platform we're on; currently, we only need
+# to distinguish between compiling on a Win32 box or not.
+
+# Iff the OS env variable isn't defined, check for windir.
+IS_WIN9x=$(patsubst X%X,YES,$(subst XX,NO,X$(windir)X))
+FOR_WIN32=$(patsubst X%X,YES,$(subst XX,$(IS_WIN9x),X$(OS)X))
+
+ifeq "$(STANDALONE_DIST)" "YES"
+# This rule makes sure that "all" is the default target, regardless of where it appears
+#		THIS RULE MUST REMAIN FIRST!
+default: all
+
+include $(TOP)/config.mk
+endif
+
+WAYS=$(HDirectWays)
+
+ifneq "$(STANDALONE_DIST)" "YES"
+GHC_TOP=$(HDIRECT_TOP)/../ghc
+include $(GHC_TOP)/mk/paths.mk
+endif
+
+include $(TOP)/mk/paths.mk
+include $(TOP)/mk/opts.mk
+include $(TOP)/mk/suffix.mk
+include $(TOP)/mk/version.mk
+
+ifeq "$(STANDALONE_DIST)" "YES"
+-include .depend
+endif
+ mk/config.mk view
@@ -0,0 +1,12 @@+#
+# HaskellDirect project information
+#
+
+# what to include in a binary distribution
+HaskellDirectMainDir 		= hdirect
+HaskellDirectBinDistDirs 	= hdirect
+HaskellDirectBinDistDocs 	= hdirect/doc
+HaskellDirectBinDistShScripts 	= hdirect-$(ProjectVersion)
+HaskellDirectBinDistLinks 	= hdirect
+
+include $(HaskellDirectMainDir)/mk/version.mk
+ mk/opts.mk view
@@ -0,0 +1,33 @@+#
+# H/Direct specific paths and settings.
+#
+# Currently just controlling the invocation of
+# of ihc/hdirect itself.
+#
+
+
+IHC_OPTS = $(SRC_IHC_OPTS) $(WAY$(_way)_IHC_OPTS) $($*_IHC_OPTS) $(EXTRA_IHC_OPTS)
+
+ifeq "$(STANDALONE_DIST)" "YES"
+HC_OPTS            = $(SRC_HC_OPTS) $(WAY$(_way)_HC_OPTS) $($*_HC_OPTS) $(EXTRA_HC_OPTS)
+AR_OPTS            = $(SRC_AR_OPTS) $(WAY$(_way)_AR_OPTS) $(EXTRA_AR_OPTS)
+CPP_OPTS           = $(SRC_CPP_OPTS) $(WAY$(_way)_CPP_OPTS) $(EXTRA_CPP_OPTS)
+CC_OPTS            = $(SRC_CC_OPTS) $(WAY$(_way)_CC_OPTS) $($*_CC_OPTS) $(EXTRA_CC_OPTS)
+HAPPY_OPTS         = $(SRC_HAPPY_OPTS) $(WAY$(_way)_HAPPY_OPTS) $($*_HAPPY_OPTS) $(EXTRA_HAPPY_OPTS)
+GREENCARD_OPTS     = $(SRC_GREENCARD_OPTS) $(WAY$(_way)_GREENCARD_OPTS) $($*_GREENCARD_OPTS) $(EXTRA_GREENCARD_OPTS)
+INSTALL_OPTS       = $(SRC_INSTALL_OPTS) $(WAY$(_way)_INSTALL_OPTS) $(EXTRA_INSTALL_OPTS)
+INSTALL_BIN_OPTS   = $(INSTALL_OPTS) $(SRC_INSTALL_BIN_OPTS)
+LD_OPTS            = $(SRC_LD_OPTS) $(WAY$(_way)_LD_OPTS) $(EXTRA_LD_OPTS)
+MKDEPENDC_OPTS     = $(SRC_MKDEPENDC_OPTS) $(WAY$(_way)_MKDEPENDC_OPTS) $(EXTRA_MKDEPENDC_OPTS)
+MKDEPENDHS_OPTS    = $(SRC_MKDEPENDHS_OPTS) $(WAY$(_way)_MKDEPENDHS_OPTS) \
+                     $(EXTRA_MKDEPENDHS_OPTS)
+ZIP_OPTS           = $(SRC_ZIP_OPTS) $(EXTRA_ZIP_OPTS)
+SRC_AR_OPTS += clqs
+
+endif
+
+SGML2LATEX_OPTS    = $(SRC_SGML2LATEX_OPTS) $(WAY$(_way)_SGML2LATEX_OPTS) $(EXTRA_SGML2LATEX_OPTS)
+SGML2INFO_OPTS     = $(SRC_SGML2INFO_OPTS) $(WAY$(_way)_SGML2INFO_OPTS) $(EXTRA_INFO_OPTS)
+SGML2TXT_OPTS      = $(SRC_SGML2TXT_OPTS) $(WAY$(_way)_SGML2TXT_OPTS) $(EXTRA_SGML2TXT_OPTS)
+SGML2HTML_OPTS     = $(SRC_SGML2HTML_OPTS) $(WAY$(_way)_SGML2HTML_OPTS) $(EXTRA_SGML2HTML_OPTS)
+
+ mk/paths.mk view
@@ -0,0 +1,107 @@+#
+# H/Direct specific paths and settings.
+#
+# Currently just controlling the invocation of
+# of ihc/hdirect itself.
+#
+
+ifndef IHC
+IHC = $(TOP)/src/ihc
+endif
+
+#
+# HDirect documentation uses sgmltools, which
+# is no longer used for fptools/, so provide defns
+# of the misc tools we're using from that package.
+# (see suffix.mk for .sgml -> ?? rules)
+#
+ifndef SGMLVERB
+SGMLVERB = sgmlverb
+endif
+
+ifndef SGML2LATEX
+SGML2LATEX = sgml2latex
+endif
+
+ifndef SGML2HTML
+SGML2HTML = sgml2html
+endif
+
+ifndef SGML2INFO
+SGML2INFO = sgml2info
+endif
+
+ifndef SGML2TXT
+SGML2TXT = sgml2txt
+endif
+
+ifndef CP
+CP=cp
+endif
+
+IDL_SRCS=$(filter %.idl,$(SRCS) $(BOOT_SRCS))
+IDL_OBJS=$(addsuffix .hs,$(basename $(IDL_SRCS)))
+
+ifeq "$(STANDALONE_DIST)" "YES"
+SRCS=$(wildcard *.lhs *.hs *.c *.lc *.prl *.lprl *.lit *.verb)
+
+HS_SRCS=$(filter %.lhs %.hs %.hc,$(SRCS) $(BOOT_SRCS))
+HS_OBJS=$(addsuffix .$(way_)o,$(basename $(HS_SRCS)))
+HS_IFACES=$(addsuffix .$(way_)hi,$(basename $(HS_SRCS)))
+
+C_SRCS=$(filter %.lc %.c,$(SRCS))
+C_OBJS=$(addsuffix .$(way_)o,$(basename $(C_SRCS)))
+
+OBJS=$(HS_OBJS) $(C_OBJS) $(SCRIPT_OBJS)
+
+MKDEPENDHS_SRCS=$(HS_SRCS)
+MKDEPENDC_SRCS=$(C_SRCS)
+
+MOSTLY_CLEAN_FILES     += $(HS_OBJS) $(C_OBJS)
+CLEAN_FILES            += $(HS_PROG) $(C_PROG) $(SCRIPT_PROG) $(PROG) $(LIBRARY) \
+			  $(HS_IFACES) \
+			  a.out core
+
+endif
+
+#
+# The default is to use dllwrap and gcc to compile up
+# the Hugs stubs. Should you want to use MSVC++ tools instead,
+# you need to set USE_MSVC_TOOLS to ... YES.
+#
+ifeq "$(USE_MSVC_TOOLS)" "YES"
+CCDLL=cl
+CCDLL_OPTS=/Zi /LD /MD /I.
+#SRC_CC_OPTS += /LD /MD
+CCDLL_LIBS=ole32.lib oleaut32.lib uuid.lib advapi32.lib user32.lib winmm.lib urlmon.lib msvcrt.lib
+#CC:=cl
+STUB_OBJ_SUFFIX=obj
+else
+ifeq "$(FOR_WIN32)" "YES"
+CCDLL=dllwrap 
+CCDLL_OPTS += --def HugsMod.def
+CCDLL_OPTS += -mno-cygwin --target=i386-mingw32
+CCDLL_LIBS += -loleaut32 -lole32 -luser32
+CLEAN_FILES += $(wildcard *.dll_o *.dll)
+else
+#
+# Producing a .so file.
+#
+CCDLL=gcc
+CCDLL_OPTS=-fPIC -shared -nostdlib
+CLEAN_FILES += $(wildcard *.dll_o *.so)
+endif
+STUB_OBJ_SUFFIX=dll_o
+endif
+
+#
+# File extensions for executables and DLLs. The current assumption is that
+# anything non-Win32, uses the .so extension. Tweak to fit if that's
+# not the case on your plat.
+#
+ifeq "$(FOR_WIN32)" "YES"
+exeext=.exe
+dllext=dll
+else
+dllext=so
+endif
+ mk/should_compile.mk view
@@ -0,0 +1,14 @@+#-----------------------------------------------------------------------------
+# template for should_compile tests.
+
+IDL_SRCS += $(wildcard *.idl)
+
+SRC_RUNTEST_OPTS += -o1 $*.stdout -o2 $*.stderr -x 0
+
+# Override default .idl -> .hs pattern rule.
+%.hs : %.idl
+	@echo ---- Testing for successful compilation of $<
+	$(RUNTEST) $(IHC) $(RUNTEST_OPTS) -- $(IHC_OPTS) -c $< -o $@
+
+all :: $(IDL_OBJS)
+
+ mk/should_fail.mk view
@@ -0,0 +1,12 @@+#-----------------------------------------------------------------------------
+# template for should_fail tests
+
+IDL_SRCS += $(wildcard *.idl)
+
+SRC_RUNTEST_OPTS += -o1 $*.stdout -o2 $*.stderr -x 1
+
+%.hs : %.idl
+	@echo ---- Testing for failure to compile $<
+	@$(RUNTEST) $(IHC) $(RUNTEST_OPTS) -- $(IHC_OPTS) -c $< -o $@
+
+all :: $(IDL_OBJS)
+ mk/suffix.mk view
@@ -0,0 +1,80 @@+#
+# .idl -> .hs suffix rule
+# 
+
+%.hs : %.idl
+	$(IHC) $(IHC_OPTS) -c $< -o $@
+
+%.hs : %.odl
+	$(IHC) $(IHC_OPTS) -c $< -o $@
+
+.PRECIOUS: %.hs
+
+%.hs : %.y
+	$(HAPPY) $(HAPPY_OPTS) $<
+
+#-----------------------------------------------------------------------------
+# SGML suffix rules -- override whatever tools that are used higher up.
+#
+#
+%.sgml : %.vsgml
+	@$(RM) $@
+	expand $< | $(SGMLVERB) > $@
+
+%.tex : %.sgml
+	@$(RM) $@
+	$(SGML2LATEX) $(SGML2LATEX_OPTS) -m --output=tex $<
+
+%.dvi : %.sgml
+	@$(RM) $@
+	$(SGML2LATEX) $(SGML2LATEX_OPTS) -m --output=dvi $<
+
+%.ps : %.sgml
+	@$(RM) $@
+	$(SGML2LATEX) $(SGML2LATEX_OPTS) -m --output=ps $<
+
+%.html : %.sgml
+	@$(RM) $@
+	$(SGML2HTML) $(SGML2HTML_OPTS) $<
+
+%.info : %.sgml
+	@$(RM) $@
+	$(SGML2INFO) $(SGML2INFO_OPTS) $<
+
+%.txt : %.sgml
+	@$(RM) $@
+	$(SGML2TXT) $(SGML2TXT_OPTS) $<
+
+
+
+ifeq "$(STANDALONE_DIST)" "YES"
+
+%.$(way_)o : %.hs
+	$(HC_PRE_OPTS)
+	$(HC) $(HC_OPTS) -c $< -o $@ -osuf $(subst .,,$(suffix $@))
+	$(HC_POST_OPTS)
+			 
+%.$(way_)o : %.lhs	 
+	$(HC_PRE_OPTS)
+	$(HC) $(HC_OPTS) -c $< -o $@ -osuf $(subst .,,$(suffix $@))
+	$(HC_POST_OPTS)
+
+%.$(way_)hi : %.$(way_)o
+	@:
+
+.PRECIOUS: %.hs
+
+%.hs : %.ly
+	$(HAPPY) $(HAPPY_OPTS) $<
+
+%.hs : %.gc
+	$(GREENCARD) $(GREENCARD_OPTS) $< -o $@
+
+%.lhs : %.gc
+	$(GREENCARD) $(GREENCARD_OPTS) $< -o $@
+
+%.$(way_)o : %.c
+	@$(RM) $@
+	$(CC) $(CC_OPTS) -c $< -o $@
+
+endif
+ mk/target.mk view
@@ -0,0 +1,377 @@+#-----------------------------------------------------------------------------
+#
+# target.mk project stub
+#
+#-----------------------------------------------------------------------------
+
+# We need to set TOP to be the TOP that the next level up expects!
+# The TOP variable is reset after the inclusion of the fptools
+# boilerplate, so we stash TOP away first:
+
+ifneq "$(STANDALONE_DIST)" "YES"
+HDIRECT_TOP := $(TOP)
+TOP:=$(TOP)/..
+
+ifneq "$(HDirectHC)" ""
+HC=$(HDirectHC)
+MKDEPENDHS=$(HDirectHC)
+endif
+
+include $(TOP)/mk/target.mk
+
+# Reset TOP
+TOP:=$(HDIRECT_TOP)
+endif
+
+ifeq "$(STANDALONE_DIST)" "YES"
+.PHONY: all
+
+ifneq "$(HS_PROG)" ""
+all :: $(HS_PROG)
+
+$(HS_PROG) :: $(HS_OBJS)
+	$(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(HS_OBJS) $(LIBS)
+endif
+
+ifneq "$(C_PROG)" ""
+all :: $(C_PROG)
+
+$(C_PROG) :: $(C_OBJS)
+	$(CC) -o $@ $(CC_OPTS) $(LD_OPTS) $(C_OBJS) $(LIBS)
+endif
+
+ifneq "$(LIBRARY)" ""
+
+all :: $(LIBRARY)
+
+$(LIBRARY) :: $(LIBOBJS)
+	$(RM) $@
+	$(AR) $(AR_OPTS) $@ $(LIBOBJS)
+endif
+
+ifneq "$(MOSTLY_CLEAN_FILES)" ""
+mostlyclean::
+	rm -f $(MOSTLY_CLEAN_FILES)
+endif
+
+ifneq "$(CLEAN_FILES)" ""
+clean:: mostlyclean
+	rm -f $(CLEAN_FILES)
+endif
+
+.PHONY: depend
+
+# Compiler produced files that are targets of the source's imports.
+MKDEPENDHS_OBJ_SUFFICES=o
+
+depend :: $(MKDEPENDHS_SRCS) $(MKDEPENDC_SRCS)
+	@$(RM) .depend
+	@touch .depend
+ifneq "$(DOC_SRCS)" ""
+	$(MKDEPENDLIT) -o .depend $(MKDEPENDLIT_OPTS) $(filter %.lit,$(DOC_SRCS))
+endif
+ifneq "$(MKDEPENDHS_SRCS)" ""
+	$(MKDEPENDHS) -M -optdep-f -optdep.depend $(foreach way,$(WAYS),-optdep-s -optdep$(way)) $(foreach obj,$(MKDEPENDHS_OBJ_SUFFICES),-optdep-o -optdep$(obj)) $(MKDEPENDHS_OPTS) $(patsubst -odir,,$(HC_OPTS)) $(MKDEPENDHS_SRCS)
+endif
+
+# the above patsubst is a hack to remove the '-odir $*' from HC_OPTS
+# which is present when we're splitting objects.  The $* maps to
+# nothing, since this isn't a pattern rule, so we have to get rid of
+# the -odir too to avoid problems.
+
+.PHONY: boot
+boot :: depend
+
+ifneq "$(SUBDIRS)" ""
+
+all docs runtests boot TAGS clean veryclean maintainer-clean install info ::
+	@echo "------------------------------------------------------------------------"
+	@echo "===fptools== Recursively making \`$@' in $(SUBDIRS) ..."
+	@echo "PWD = $(shell pwd)"
+	@echo "------------------------------------------------------------------------"
+# Don't rely on -e working, instead we check exit return codes from sub-makes.
+	@case '${MFLAGS}' in *-[ik]*) x_on_err=0;; *-r*[ik]*) x_on_err=0;; *) x_on_err=1;; esac; \
+	for i in $(SUBDIRS); do \
+	  echo "------------------------------------------------------------------------"; \
+	  echo "==fptools== $(MAKE) $@ $(MFLAGS);"; \
+	  echo " in $(shell pwd)/$$i"; \
+	  echo "------------------------------------------------------------------------"; \
+	  $(MAKE) --no-print-directory -C $$i $(MFLAGS) $@; \
+	  if [ $$? -eq 0 -o $$x_on_err -eq 0 ] ;  then true; else exit 1; fi; \
+	done
+	@echo "------------------------------------------------------------------------"
+	@echo "===fptools== Finished making \`$@' in $(SUBDIRS) ..."
+	@echo "PWD = $(shell pwd)"
+	@echo "------------------------------------------------------------------------"
+
+endif
+
+###########################################
+#
+#	Targets: install install-strip uninstall
+#
+###########################################
+
+# For each of these variables that is defined, you
+# get one install rule
+#
+#	INSTALL_PROGS 	     executable programs in $(bindir)
+#	INSTALL_SCRIPTS	     executable scripts in $(bindir)
+#	INSTALL_LIBS	     platform-dependent libraries in $(libdir) (ranlib'ed)
+#	INSTALL_LIB_SCRIPTS  platform-dependent scripts   in $(libdir)
+#	INSTALL_LIBEXECS     platform-dependent execs in $(libdir)
+#	INSTALL_DATAS	     platform-independent files in $(datadir)
+#
+# If the installation directory variable is undefined, the install rule simply
+# emits a suitable error message.
+#
+# Remember, too, that the installation directory variables ($(bindir) and
+# friends can be overridden from their original settings in mk/config.mk.in
+# || mk/build.mk
+#
+.PHONY: install installdirs install-strip install-dirs uninstall install-docs show-install
+
+show-install :
+	@echo "bindir = $(bindir)"
+	@echo "libdir = $(libdir)"
+	@echo "libexecdir = $(libexecdir)  # by default, same as libdir"
+	@echo "datadir = $(datadir)  # unused for ghc project"
+
+INSTALL_DIR=$(TOP)/mkdirhier
+
+INSTALL=$(TOP)/install-sh
+INSTALL_PROGRAM = $(INSTALL) -m 755
+INSTALL_SCRIPT  = $(INSTALL) -m 755
+INSTALL_DATA    = $(INSTALL) -m 644
+RANLIB=:
+
+#
+# Sometimes useful to separate out the creation of install directories 
+# from the installation itself.
+#
+install-dirs ::
+	@$(INSTALL_DIR) $(bindir)
+	@$(INSTALL_DIR) $(libdir)
+	@$(INSTALL_DIR) $(libexecdir)
+	@$(INSTALL_DIR) $(datadir)
+
+# Better do this first...
+# but we won't for the moment, do it on-demand from
+# within the various install targets instead.
+#install:: install-dirs
+
+ifneq "$(INSTALL_PROGS)" ""
+
+#
+# Here's an interesting one - when using the win32 version
+# of install (provided via the cygwin toolkit), we have to
+# supply the .exe suffix, *if* there's no other suffix.
+#
+# The rule below does this by ferreting out the suffix of each
+# entry in the INSTALL_PROGS list. If there's no suffix, use
+# $(exeext).
+# 
+# This is bit of a pain to express since GNU make doesn't have
+# something like $(if ...), but possible using $(subst ..)
+# [Aside: I added support for $(if ..) to my local copy of GNU
+# make at one stage, perhaps I should propagate the patch to
+# the GNU make maintainers..] 
+#
+INSTALL_PROGS := $(foreach p, $(INSTALL_PROGS), $(addsuffix $(subst _,,$(subst __,$(exeext),_$(suffix $(p))_)), $(basename $(p))))
+
+install:: $(INSTALL_PROGS)
+	@$(INSTALL_DIR) $(bindir)
+	@for i in $(INSTALL_PROGS); do \
+		    echo $(INSTALL_PROGRAM) $(INSTALL_BIN_OPTS) $$i $(bindir); \
+		    $(INSTALL_PROGRAM) $(INSTALL_BIN_OPTS) $$i $(bindir) ;  \
+	done
+endif
+
+#
+# Just like INSTALL_PROGS, but prefix with install sites bin/lib/data and
+# install without stripping.
+#
+ifneq "$(INSTALL_SCRIPTS)" ""
+install:: $(INSTALL_SCRIPTS)
+	@$(INSTALL_DIR) $(bindir)
+	for i in $(INSTALL_SCRIPTS); do \
+		$(INSTALL_SCRIPT) $(INSTALL_OPTS) $$i $(bindir); \
+	done
+endif
+
+ifneq "$(INSTALL_LIB_SCRIPTS)" ""
+install:: $(INSTALL_LIB_SCRIPTS)
+	@$(INSTALL_DIR) $(libdir)
+	for i in $(INSTALL_LIB_SCRIPTS); do \
+		$(INSTALL_SCRIPT) $(INSTALL_OPTS) $$i $(libdir); \
+	done
+endif
+
+ifneq "$(INSTALL_LIBEXEC_SCRIPTS)" ""
+install:: $(INSTALL_LIBEXEC_SCRIPTS)
+	@$(INSTALL_DIR) $(libexecdir)
+	for i in $(INSTALL_LIBEXEC_SCRIPTS); do \
+		$(INSTALL_SCRIPT) $(INSTALL_OPTS) $$i $(libexecdir); \
+	done
+endif
+
+ifneq "$(INSTALL_LIBS)" ""
+install:: $(INSTALL_LIBS)
+	@$(INSTALL_DIR) $(libdir)
+	for i in $(INSTALL_LIBS); do \
+		case $$i in \
+		  *.a) \
+		    $(INSTALL_DATA) $(INSTALL_OPTS) $$i $(libdir); \
+		    $(RANLIB) $(libdir)/`basename $$i` ;; \
+		  *.dll) \
+		    $(INSTALL_DATA) -s $(INSTALL_OPTS) $$i $(libdir) ;; \
+		  *) \
+		    $(INSTALL_DATA) $(INSTALL_OPTS) $$i $(libdir); \
+		esac; \
+	done
+endif
+
+ifneq "$(INSTALL_LIBEXECS)" ""
+#
+# See above comment next to defn of INSTALL_PROGS for what
+# the purpose of this one-liner is.
+# 
+INSTALL_LIBEXECS := $(foreach p, $(INSTALL_LIBEXECS), $(addsuffix $(subst _,,$(subst __,$(exeext),_$(suffix $(p))_)), $(basename $(p))))
+
+install:: $(INSTALL_LIBEXECS)
+	@$(INSTALL_DIR) $(libexecdir)
+	-for i in $(INSTALL_LIBEXECS); do \
+		$(INSTALL_PROGRAM) $(INSTALL_BIN_OPTS) $$i $(libexecdir); \
+	done
+endif
+
+ifneq "$(INSTALL_DATAS)" ""
+install:: $(INSTALL_DATAS)
+	@$(INSTALL_DIR) $(datadir)
+	for i in $(INSTALL_DATAS); do \
+		$(INSTALL_DATA) $(INSTALL_OPTS) $$i $(datadir); \
+	done
+endif
+
+ifneq "$(INSTALL_INCLUDES)" ""
+install:: $(INSTALL_INCLUDES)
+	@$(INSTALL_DIR) $(includedir)
+	for i in $(INSTALL_INCLUDES); do \
+		$(INSTALL_DATA) $(INSTALL_OPTS) $$i $(includedir); \
+	done
+endif
+
+#
+# Use with care..
+#
+uninstall:: 
+	@for i in $(INSTALL_PROGS) "" ; do			\
+	  if test "$$i"; then 					\
+		echo rm -f $(bindir)/`basename $$i`;		\
+		rm -f $(bindir)/`basename $$i`;			\
+	  fi; 							\
+	done
+	@for i in $(INSTALL_LIBS) ""; do			\
+	  if test "$$i"; then 					\
+		echo rm -f $(libdir)/`basename $$i`;		\
+		rm -f $(libdir)/`basename $$i`;			\
+	  fi;							\
+	done
+	@for i in $(INSTALL_LIBEXECS) ""; do			\
+	  if test "$$i"; then 					\
+		echo rm -f $(libexecdir)/`basename $$i`;	\
+		rm -f $(libexecdir)/`basename $$i`;		\
+	  fi;							\
+	done
+	@for i in $(INSTALL_DATAS) ""; do			\
+	  if test "$$i"; then 					\
+		echo rm -f $(datadir)/`basename $$i`;		\
+		rm -f $(datadir)/`basename $$i`;		\
+	  fi;							\
+	done
+
+#
+# install-strip is from the GNU Makefile standard.
+#
+ifneq "$(way)" ""
+install-strip::
+	@$(MAKE) EXTRA_INSTALL_OPTS='-s' install                                	
+endif
+
+#
+# install links to script drivers.
+#
+ifneq "$(SCRIPT_LINK)" ""
+install ::
+	@if ( $(PERL) -e '$$fn="$(bindir)/$(SCRIPT_LINK)"; exit ((! -f $$fn || -l $$fn) ? 0 : 1);' ); then \
+	   echo "Creating a symbol link from $(SCRIPT_PROG) to $(SCRIPT_LINK) in $(bindir)"; \
+	   $(RM) $(bindir)/$(SCRIPT_LINK); \
+	   $(LN_S) $(SCRIPT_PROG) $(bindir)/$(SCRIPT_LINK); \
+	 else \
+	   echo "Creating a symbol link from $(SCRIPT_PROG) to $(SCRIPT_LINK) in $(bindir) failed: \`$(bindir)/$(SCRIPT_LINK)' already exists"; \
+	   echo "Perhaps remove \`$(bindir)/$(SCRIPT_LINK)' manually?"; \
+	   exit 1; \
+	 fi;
+
+endif
+
+
+endif
+
+# -----------------------------------------------------------------------------
+# Building source distributions
+#
+# Do it like this: 
+#
+#	$ make
+#	$ make dist Project=Ghc
+#
+# WARNING: `make dist' calls `make distclean' before tarring up the tree.
+#
+
+.PHONY: dist
+
+SRC_DIST_DIR=$(shell pwd)/$(SRC_DIST_NAME)
+
+ifneq "$(SUBDIRS)" ""
+dist ::
+# Don't rely on -e working, instead we check exit return codes from sub-makes.
+	echo $(SUBDIRS)
+	@case '${MFLAGS}' in *-[ik]*) x_on_err=0;; *-r*[ik]*) x_on_err=0;; *) x_on_err=1;; esac; \
+	for i in $(SUBDIRS) ; do \
+	  $(MKDIRHIER) $(SRC_DIST_DIR)/$$i; \
+	  $(MAKE) -C $$i $(MFLAGS) $@ SRC_DIST_DIR=$(SRC_DIST_DIR)/$$i; \
+	  if [ $$? -eq 0 ] ;  then true; else exit $$x_on_err; fi; \
+	done
+endif
+
+# The default dist rule:
+#
+# copy/link the contents of $(SRC_DIST_FILES) into the
+# shadow distribution tree. SRC_DIST_FILES contain the
+# build-generated files that you want to include in
+# a source distribution.
+#
+#
+ifneq "$(SRC_DIST_FILES)" ""
+dist::
+	@for i in $(SRC_DIST_FILES); do 		 \
+	  if ( echo "$$i" | grep "~" >/dev/null 2>&1 ); then	 \
+	    echo $(LN_S) `pwd`/`echo $$i | sed -e "s/^\([^~]*\)~.*/\1/g"` $(SRC_DIST_DIR)/`echo $$i | sed -e "s/.*~\(.*\)/\1/g"` ; \
+	    $(LN_S) `pwd`/`echo $$i | sed -e "s/^\([^~]*\)~.*/\1/g"` $(SRC_DIST_DIR)/`echo $$i | sed -e "s/.*~\(.*\)/\1/g"` ; \
+	  else \
+	    if (test -f "$$i"); then 			   \
+	      echo $(LN_S) `pwd`/$$i $(SRC_DIST_DIR)/$$i ; \
+	      $(LN_S) `pwd`/$$i $(SRC_DIST_DIR)/$$i ;	   \
+	     fi;					   \
+	  fi; \
+	done;
+endif
+
+dist-package :: dist-package-tar-gz
+
+dist-package-tar-gz ::
+	$(TAR) chzf $(SRC_DIST_NAME)-src.tar.gz $(SRC_DIST_NAME)
+
+dist-package-zip ::
+	cd ..; $(ZIP) $(ZIP_OPTS) -r $(SRC_DIST_NAME)-src.zip $(SRC_DIST_DIR)
+ mk/version.mk view
@@ -0,0 +1,18 @@+#
+# Project-specific version information.
+#
+# Note:
+#   this config file is intended to centralise all
+#   project version information. To bump up the version
+#   info on your package, edit this file and recompile
+#   all the dependents. This file lives in the source tree.
+#
+
+#
+# hdirect project variable settings:
+#
+ProjectName       = HaskellDirect
+ProjectNameShort  = hdirect
+ProjectVersion    = 0.21
+ProjectVersionInt = 021
+ProjectPatchLevel = 0
+ mkdirhier view
@@ -0,0 +1,34 @@+#!/bin/sh
+
+#
+# create a hierarchy of directories
+#
+# Based on Noah Friedman's mkinstalldirs..
+#
+errs=0
+
+for f in $*; do
+    parts=`echo ":$f" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'`
+    path="";
+    for p in $parts; do
+        path="$path$p"
+        case "$path" in
+          -* ) path=./$path ;;
+        esac
+
+        if test ! -d "$path"; then
+           echo "mkdir $path" 1>&2
+
+           mkdir "$path" || lasterr=$?
+	   
+	   if test ! -d "$path"; then
+	      errs=$lasterr
+           fi 
+        fi
+	path="$path/";
+    done;
+done
+
+exit $errs
+
+# end of story
+ scripts/Parse.hs view
@@ -0,0 +1,89 @@+import Parser+import LexM+import Pretty+import PpIDLSyn++import Control.Monad+import System.IO+import System.Environment+import System.FilePath++main = do+    [f,g]          <- getArgs+    [src_f, src_g] <-+      forM [f,g] $ \a -> do+        src    <- readFile a+        Left x <- runLexM [] f src parseIDL+        return x++    if (src_f == src_g)+       then print "The input IDL is structurally identical"+       else do putStrLn $ showIDL (ppIDL f src_f)+               putStrLn $ showIDL (ppIDL g src_g)++{-++$ runhaskell Parse.hs math.idl math.idl++True+module Math {+[pure]+long abs([in] long x);;+[pure]+long labs([in] long x);;+[pure]+double fabs([in] double x);;+[pure]+double ceil([in] double x);;+[pure]+double floor([in] double x);;+[pure]+double fmod([in] double x,+            [in] double y);;+[pure]+double exp([in] double x);;+[pure]+double log([in] double x);;+[pure]+double log10([in] double x);;+[pure]+double frexp([in] double x,+             [in, out, ref] long *nptr);;+[pure]+double ldexp([in] double x,+             [in] long n);;+[pure]+double modf([in] double x,+            [in, out, ref] double *nptr);;+[pure]+double pow([in] double x,+           [in] double y);;+[pure]+double sqrt([in] double x);;+[pure]+long rand([in] void );;+void srand([in] long seed);;+[pure]+double cos([in] double x);;+[pure]+double sin([in] double x);;+[pure]+double tan([in] double x);;+[pure]+double acos([in] double x);;+[pure]+double asin([in] double x);;+[pure]+double atan([in] double x);;+[pure]+double atan2([in] double x,+             [in] double y);;+[pure]+double cosh([in] double x);;+[pure]+double sinh([in] double x);;+[pure]+double tanh([in] double x);;+};++        -}
+ scripts/math.idl view
@@ -0,0 +1,38 @@+module Math {++  [pure]int  abs([in]int x);+  [pure]long labs([in]long x);+  [pure]double fabs([in]double x);++  [pure]double ceil([in]double x);+  [pure]double floor([in]double x);+  [pure]double fmod([in]double x,[in]double y);++  [pure]double exp([in]double x);+  [pure]double log([in]double x);+  [pure]double log10([in]double x);++  [pure]double frexp([in]double x,[in,out,ref]int* nptr);+  [pure]double ldexp([in]double x,[in]int n);+  [pure]double modf([in]double x,[in,out,ref]double* nptr);++  [pure]double pow([in]double x,[in]double y);+  [pure]double sqrt([in]double x);++  [pure]int rand(void);+  void srand([in]int seed);+  +  [pure]double cos([in]double x);+  [pure]double sin([in]double x);+  [pure]double tan([in]double x);++  [pure]double acos([in]double x);+  [pure]double asin([in]double x);+  [pure]double atan([in]double x);+  [pure]double atan2([in]double x,+                     [in]double y);++  [pure]double cosh([in]double x);+  [pure]double sinh([in]double x);+  [pure]double tanh([in]double x);+};
+ src/.depend view
@@ -0,0 +1,538 @@+# DO NOT DELETE: Beginning of C dependencies
+ErrorHook.o: ErrorHook.c
+mkNativeInfo.o: mkNativeInfo.c
+# DO NOT DELETE: End of C dependencies
+# DO NOT DELETE: Beginning of Haskell dependencies
+AbsHUtils.o : AbsHUtils.lhs
+AbsHUtils.o : Opts.hi
+AbsHUtils.o : LibUtils.hi
+AbsHUtils.o : BasicTypes.hi
+AbsHUtils.o : Literal.hi
+AbsHUtils.o : AbstractH.hi
+AbstractH.o : AbstractH.lhs
+AbstractH.o : BasicTypes.hi
+AbstractH.o : Literal.hi
+Attribute.o : Attribute.lhs
+Attribute.o : Utils.hi
+Attribute.o : CoreIDL.hi
+Attribute.o : Literal.hi
+Attribute.o : BasicTypes.hi
+Bag.o : Bag.lhs
+BasicTypes.o : BasicTypes.lhs
+BasicTypes.o : Utils.hi
+BasicTypes.o : Opts.hi
+BasicTypes.o : PP.hi
+CStubGen.o : CStubGen.lhs
+CStubGen.o : Utils.hi
+CStubGen.o : Opts.hi
+CStubGen.o : BasicTypes.hi
+CStubGen.o : PP.hi
+CStubGen.o : AbsHUtils.hi
+CStubGen.o : AbstractH.hi
+CgMonad.o : CgMonad.lhs
+CgMonad.o : BasicTypes.hi
+CgMonad.o : Opts.hi
+CgMonad.o : CoreIDL.hi
+CgMonad.o : AbstractH.hi
+CgMonad.o : Env.hi
+CodeGen.o : CodeGen.lhs
+CodeGen.o : Env.hi
+CodeGen.o : Utils.hi
+CodeGen.o : Attribute.hi
+CodeGen.o : CoreUtils.hi
+CodeGen.o : CoreIDL.hi
+CodeGen.o : CgMonad.hi
+CodeGen.o : PpCore.hi
+CodeGen.o : PpAbstractH.hi
+CodeGen.o : Opts.hi
+CodeGen.o : LibUtils.hi
+CodeGen.o : MkImport.hi
+CodeGen.o : AbsHUtils.hi
+CodeGen.o : AbstractH.hi
+CodeGen.o : Literal.hi
+CodeGen.o : BasicTypes.hi
+CodeGen.o : CustomAttributes.hi
+CodeGen.o : Skeleton.hi
+CodeGen.o : MarshallJServ.hi
+CodeGen.o : MarshallJNI.hi
+CodeGen.o : MarshallFun.hi
+CodeGen.o : MarshallCore.hi
+CodeGen.o : MarshallServ.hi
+CodeGen.o : MarshallAbstract.hi
+CodeGen.o : MarshallUnion.hi
+CodeGen.o : MarshallMethod.hi
+CodeGen.o : MarshallType.hi
+CodeGen.o : MarshallEnum.hi
+CodeGen.o : MarshallStruct.hi
+CodeGen.o : MarshallUtils.hi
+CoreIDL.o : CoreIDL.lhs
+CoreIDL.o : TypeInfo.hi
+CoreIDL.o : BasicTypes.hi
+CoreIDL.o : Literal.hi
+CoreUtils.o : CoreUtils.lhs
+CoreUtils.o : Env.hi
+CoreUtils.o : NativeInfo.hi
+CoreUtils.o : TypeInfo.hi
+CoreUtils.o : Utils.hi
+CoreUtils.o : Digraph.hi
+CoreUtils.o : PpCore.hi
+CoreUtils.o : Opts.hi
+CoreUtils.o : LibUtils.hi
+CoreUtils.o : Literal.hi
+CoreUtils.o : Attribute.hi
+CoreUtils.o : BasicTypes.hi
+CoreUtils.o : CoreIDL.hi
+DefGen.o : DefGen.lhs
+DefGen.o : Utils.hi
+DefGen.o : AbstractH.hi
+Desugar.o : Desugar.lhs
+Desugar.o : Validate.hi
+Desugar.o : TypeInfo.hi
+Desugar.o : NameSupply.hi
+Desugar.o : LibUtils.hi
+Desugar.o : PpCore.hi
+Desugar.o : PpIDLSyn.hi
+Desugar.o : ImportLib.hi
+Desugar.o : NormaliseType.hi
+Desugar.o : Utils.hi
+Desugar.o : Opts.hi
+Desugar.o : Literal.hi
+Desugar.o : BasicTypes.hi
+Desugar.o : Env.hi
+Desugar.o : DsMonad.hi
+Desugar.o : Attribute.hi
+Desugar.o : CoreUtils.hi
+Desugar.o : CoreIDL.hi
+Desugar.o : IDLUtils.hi
+Desugar.o : IDLSyn.hi
+Digraph.o : Digraph.lhs
+DsMonad.o : DsMonad.lhs
+DsMonad.o : TypeInfo.hi
+DsMonad.o : Opts.hi
+DsMonad.o : Env.hi
+DsMonad.o : CoreUtils.hi
+DsMonad.o : IDLSyn.hi
+DsMonad.o : CoreIDL.hi
+Env.o : Env.lhs
+Env.o : FiniteMap.hi
+FiniteMap.o : FiniteMap.lhs
+GetOpt.o : GetOpt.lhs
+GetOpt.o : Utils.hi
+HugsCodeGen.o : HugsCodeGen.lhs
+HugsCodeGen.o : Utils.hi
+HugsCodeGen.o : Opts.hi
+HugsCodeGen.o : BasicTypes.hi
+HugsCodeGen.o : PP.hi
+HugsCodeGen.o : AbsHUtils.hi
+HugsCodeGen.o : AbstractH.hi
+IDLSyn.o : IDLSyn.lhs
+IDLSyn.o : BasicTypes.hi
+IDLSyn.o : Literal.hi
+IDLToken.o : IDLToken.lhs
+IDLToken.o : Opts.hi
+IDLToken.o : SrcLoc.hi
+IDLToken.o : Literal.hi
+IDLToken.o : BasicTypes.hi
+IDLToken.o : IDLSyn.hi
+IDLUtils.o : IDLUtils.lhs
+IDLUtils.o : Env.hi
+IDLUtils.o : PpIDLSyn.hi
+IDLUtils.o : Digraph.hi
+IDLUtils.o : Opts.hi
+IDLUtils.o : Utils.hi
+IDLUtils.o : Literal.hi
+IDLUtils.o : BasicTypes.hi
+IDLUtils.o : DsMonad.hi
+IDLUtils.o : CoreIDL.hi
+IDLUtils.o : IDLSyn.hi
+ImportLib.o : ImportLib.lhs
+ImportLib.o : Utils.hi
+ImportLib.o : IDLUtils.hi
+ImportLib.o : Opts.hi
+ImportLib.o : Literal.hi
+ImportLib.o : BasicTypes.hi
+ImportLib.o : IDLSyn.hi
+JavaProxy.o : JavaProxy.lhs
+JavaProxy.o : PpCore.hi
+JavaProxy.o : PP.hi
+JavaProxy.o : Literal.hi
+JavaProxy.o : BasicTypes.hi
+JavaProxy.o : Attribute.hi
+JavaProxy.o : CoreUtils.hi
+JavaProxy.o : CoreIDL.hi
+Lex.o : Lex.lhs
+Lex.o : Opts.hi
+Lex.o : SrcLoc.hi
+Lex.o : Utils.hi
+Lex.o : BasicTypes.hi
+Lex.o : Literal.hi
+Lex.o : IDLToken.hi
+Lex.o : LexM.hi
+LexM.o : LexM.lhs
+LexM.o : Opts.hi
+LexM.o : Utils.hi
+LexM.o : PreProc.hi
+LexM.o : IDLSyn.hi
+LexM.o : IDLToken.hi
+LexM.o : SrcLoc.hi
+LexM.o : SymbolTable.hi
+LibUtils.o : LibUtils.lhs
+LibUtils.o : Opts.hi
+LibUtils.o : BasicTypes.hi
+Literal.o : Literal.lhs
+Literal.o : Opts.hi
+Literal.o : Utils.hi
+Literal.o : PP.hi
+Main.o : Main.lhs
+Main.o : ImportLib.hi
+Main.o : TLBWriter.hi
+Main.o : Env.hi
+Main.o : JavaProxy.hi
+Main.o : CStubGen.hi
+Main.o : DefGen.hi
+Main.o : HugsCodeGen.hi
+Main.o : Version.hi
+Main.o : Utils.hi
+Main.o : CodeGen.hi
+Main.o : Rename.hi
+Main.o : Desugar.hi
+Main.o : PreProc.hi
+Main.o : PpAbstractH.hi
+Main.o : AbstractH.hi
+Main.o : CoreIDL.hi
+Main.o : IDLUtils.hi
+Main.o : IDLSyn.hi
+Main.o : PpIDLSyn.hi
+Main.o : CoreUtils.hi
+Main.o : PpCore.hi
+Main.o : Opts.hi
+Main.o : OmgParser.hi
+Main.o : Parser.hi
+Main.o : LexM.hi
+MarshallAbstract.o : MarshallAbstract.lhs
+MarshallAbstract.o : CoreUtils.hi
+MarshallAbstract.o : CoreIDL.hi
+MarshallAbstract.o : Attribute.hi
+MarshallAbstract.o : Opts.hi
+MarshallAbstract.o : LibUtils.hi
+MarshallAbstract.o : AbsHUtils.hi
+MarshallAbstract.o : AbstractH.hi
+MarshallAbstract.o : Literal.hi
+MarshallAbstract.o : BasicTypes.hi
+MarshallAbstract.o : CgMonad.hi
+MarshallAbstract.o : MarshallType.hi
+MarshallAuto.o : MarshallAuto.lhs
+MarshallAuto.o : Literal.hi
+MarshallAuto.o : Opts.hi
+MarshallAuto.o : LibUtils.hi
+MarshallAuto.o : Attribute.hi
+MarshallAuto.o : BasicTypes.hi
+MarshallAuto.o : CoreUtils.hi
+MarshallAuto.o : CoreIDL.hi
+MarshallAuto.o : MarshallCore.hi
+MarshallAuto.o : MarshallType.hi
+MarshallAuto.o : AbsHUtils.hi
+MarshallAuto.o : AbstractH.hi
+MarshallCore.o : MarshallCore.lhs
+MarshallCore.o : TypeInfo.hi
+MarshallCore.o : Opts.hi
+MarshallCore.o : Utils.hi
+MarshallCore.o : PpCore.hi
+MarshallCore.o : LibUtils.hi
+MarshallCore.o : Literal.hi
+MarshallCore.o : Attribute.hi
+MarshallCore.o : BasicTypes.hi
+MarshallCore.o : MarshallUtils.hi
+MarshallCore.o : CoreUtils.hi
+MarshallCore.o : CoreIDL.hi
+MarshallCore.o : AbsHUtils.hi
+MarshallCore.o : AbstractH.hi
+MarshallDep.o : MarshallDep.lhs
+MarshallDep.o : LibUtils.hi
+MarshallDep.o : BasicTypes.hi
+MarshallDep.o : MarshallCore.hi
+MarshallDep.o : MarshallType.hi
+MarshallDep.o : MarshallUtils.hi
+MarshallDep.o : MarshallMonad.hi
+MarshallDep.o : CoreUtils.hi
+MarshallDep.o : CoreIDL.hi
+MarshallDep.o : AbsHUtils.hi
+MarshallDep.o : AbstractH.hi
+MarshallEnum.o : MarshallEnum.lhs
+MarshallEnum.o : PpCore.hi
+MarshallEnum.o : Opts.hi
+MarshallEnum.o : Literal.hi
+MarshallEnum.o : Attribute.hi
+MarshallEnum.o : CoreUtils.hi
+MarshallEnum.o : CoreIDL.hi
+MarshallEnum.o : LibUtils.hi
+MarshallEnum.o : AbsHUtils.hi
+MarshallEnum.o : CgMonad.hi
+MarshallEnum.o : AbstractH.hi
+MarshallEnum.o : BasicTypes.hi
+MarshallEnum.o : MarshallType.hi
+MarshallFun.o : MarshallFun.lhs
+MarshallFun.o : MarshallCore.hi
+MarshallFun.o : MarshallMethod.hi
+MarshallFun.o : MarshallServ.hi
+MarshallFun.o : MarshallType.hi
+MarshallFun.o : CoreUtils.hi
+MarshallFun.o : CoreIDL.hi
+MarshallFun.o : AbsHUtils.hi
+MarshallFun.o : AbstractH.hi
+MarshallFun.o : CgMonad.hi
+MarshallFun.o : LibUtils.hi
+MarshallFun.o : Literal.hi
+MarshallFun.o : Attribute.hi
+MarshallFun.o : BasicTypes.hi
+MarshallJNI.o : MarshallJNI.lhs
+MarshallJNI.o : Utils.hi
+MarshallJNI.o : Opts.hi
+MarshallJNI.o : PpCore.hi
+MarshallJNI.o : LibUtils.hi
+MarshallJNI.o : CgMonad.hi
+MarshallJNI.o : Literal.hi
+MarshallJNI.o : Attribute.hi
+MarshallJNI.o : MarshallCore.hi
+MarshallJNI.o : CoreUtils.hi
+MarshallJNI.o : AbsHUtils.hi
+MarshallJNI.o : AbstractH.hi
+MarshallJNI.o : BasicTypes.hi
+MarshallJNI.o : CoreIDL.hi
+MarshallJServ.o : MarshallJServ.lhs
+MarshallJServ.o : LibUtils.hi
+MarshallJServ.o : Utils.hi
+MarshallJServ.o : BasicTypes.hi
+MarshallJServ.o : CgMonad.hi
+MarshallJServ.o : MarshallJNI.hi
+MarshallJServ.o : MarshallUtils.hi
+MarshallJServ.o : AbsHUtils.hi
+MarshallJServ.o : AbstractH.hi
+MarshallJServ.o : PpCore.hi
+MarshallJServ.o : CoreUtils.hi
+MarshallJServ.o : Attribute.hi
+MarshallJServ.o : CoreIDL.hi
+MarshallMethod.o : MarshallMethod.lhs
+MarshallMethod.o : Utils.hi
+MarshallMethod.o : LibUtils.hi
+MarshallMethod.o : MarshallAuto.hi
+MarshallMethod.o : MarshallUtils.hi
+MarshallMethod.o : MarshallDep.hi
+MarshallMethod.o : MarshallCore.hi
+MarshallMethod.o : MarshallType.hi
+MarshallMethod.o : MarshallMonad.hi
+MarshallMethod.o : CgMonad.hi
+MarshallMethod.o : CoreUtils.hi
+MarshallMethod.o : CoreIDL.hi
+MarshallMethod.o : Opts.hi
+MarshallMethod.o : Env.hi
+MarshallMethod.o : Attribute.hi
+MarshallMethod.o : AbsHUtils.hi
+MarshallMethod.o : NativeInfo.hi
+MarshallMethod.o : AbstractH.hi
+MarshallMethod.o : Literal.hi
+MarshallMethod.o : BasicTypes.hi
+MarshallMonad.o : MarshallMonad.lhs
+MarshallMonad.o : LibUtils.hi
+MarshallMonad.o : BasicTypes.hi
+MarshallMonad.o : Env.hi
+MarshallMonad.o : AbstractH.hi
+MarshallServ.o : MarshallServ.lhs
+MarshallServ.o : Opts.hi
+MarshallServ.o : LibUtils.hi
+MarshallServ.o : BasicTypes.hi
+MarshallServ.o : CgMonad.hi
+MarshallServ.o : MarshallCore.hi
+MarshallServ.o : MarshallDep.hi
+MarshallServ.o : MarshallType.hi
+MarshallServ.o : MarshallUtils.hi
+MarshallServ.o : MarshallMonad.hi
+MarshallServ.o : MarshallMethod.hi
+MarshallServ.o : AbsHUtils.hi
+MarshallServ.o : PpAbstractH.hi
+MarshallServ.o : AbstractH.hi
+MarshallServ.o : CoreUtils.hi
+MarshallServ.o : Literal.hi
+MarshallServ.o : Attribute.hi
+MarshallServ.o : CoreIDL.hi
+MarshallStruct.o : MarshallStruct.lhs
+MarshallStruct.o : Opts.hi
+MarshallStruct.o : Utils.hi
+MarshallStruct.o : MarshallCore.hi
+MarshallStruct.o : MarshallDep.hi
+MarshallStruct.o : MarshallType.hi
+MarshallStruct.o : MarshallMonad.hi
+MarshallStruct.o : MarshallUtils.hi
+MarshallStruct.o : CoreUtils.hi
+MarshallStruct.o : CoreIDL.hi
+MarshallStruct.o : CgMonad.hi
+MarshallStruct.o : LibUtils.hi
+MarshallStruct.o : AbsHUtils.hi
+MarshallStruct.o : AbstractH.hi
+MarshallStruct.o : Attribute.hi
+MarshallStruct.o : Literal.hi
+MarshallStruct.o : BasicTypes.hi
+MarshallType.o : MarshallType.lhs
+MarshallType.o : TypeInfo.hi
+MarshallType.o : Opts.hi
+MarshallType.o : MarshallMonad.hi
+MarshallType.o : MarshallCore.hi
+MarshallType.o : PpCore.hi
+MarshallType.o : CoreUtils.hi
+MarshallType.o : CoreIDL.hi
+MarshallType.o : AbsHUtils.hi
+MarshallType.o : AbstractH.hi
+MarshallType.o : Utils.hi
+MarshallType.o : LibUtils.hi
+MarshallType.o : Literal.hi
+MarshallType.o : Attribute.hi
+MarshallType.o : BasicTypes.hi
+MarshallUnion.o : MarshallUnion.lhs
+MarshallUnion.o : Opts.hi
+MarshallUnion.o : Utils.hi
+MarshallUnion.o : LibUtils.hi
+MarshallUnion.o : CoreUtils.hi
+MarshallUnion.o : MarshallCore.hi
+MarshallUnion.o : MarshallType.hi
+MarshallUnion.o : MarshallMonad.hi
+MarshallUnion.o : CoreIDL.hi
+MarshallUnion.o : CgMonad.hi
+MarshallUnion.o : Literal.hi
+MarshallUnion.o : AbsHUtils.hi
+MarshallUnion.o : AbstractH.hi
+MarshallUnion.o : BasicTypes.hi
+MarshallUtils.o : MarshallUtils.lhs
+MarshallUtils.o : Opts.hi
+MarshallUtils.o : Utils.hi
+MarshallUtils.o : Literal.hi
+MarshallUtils.o : LibUtils.hi
+MarshallUtils.o : PpAbstractH.hi
+MarshallUtils.o : PpCore.hi
+MarshallUtils.o : AbsHUtils.hi
+MarshallUtils.o : AbstractH.hi
+MarshallUtils.o : Attribute.hi
+MarshallUtils.o : CoreIDL.hi
+MarshallUtils.o : CoreUtils.hi
+MarshallUtils.o : BasicTypes.hi
+MkImport.o : MkImport.lhs
+MkImport.o : Utils.hi
+MkImport.o : Opts.hi
+MkImport.o : BasicTypes.hi
+MkImport.o : LibUtils.hi
+MkImport.o : Env.hi
+MkImport.o : Bag.hi
+MkImport.o : AbsHUtils.hi
+MkImport.o : AbstractH.hi
+NameSupply.o : NameSupply.lhs
+NormaliseType.o : NormaliseType.lhs
+NormaliseType.o : CoreUtils.hi
+NormaliseType.o : CoreIDL.hi
+Opts.o : Opts.lhs
+Opts.o : Version.hi
+Opts.o : Utils.hi
+Opts.o : GetOpt.hi
+PP.o : PP.lhs
+PP.o : Pretty.hi
+PpAbstractH.o : PpAbstractH.lhs
+PpAbstractH.o : LibUtils.hi
+PpAbstractH.o : Utils.hi
+PpAbstractH.o : BasicTypes.hi
+PpAbstractH.o : Literal.hi
+PpAbstractH.o : Opts.hi
+PpAbstractH.o : AbsHUtils.hi
+PpAbstractH.o : AbstractH.hi
+PpAbstractH.o : PP.hi
+PpCore.o : PpCore.lhs
+PpCore.o : Attribute.hi
+PpCore.o : Utils.hi
+PpCore.o : Opts.hi
+PpCore.o : PP.hi
+PpCore.o : BasicTypes.hi
+PpCore.o : Literal.hi
+PpCore.o : CoreIDL.hi
+PpIDLSyn.o : PpIDLSyn.lhs
+PpIDLSyn.o : Opts.hi
+PpIDLSyn.o : Utils.hi
+PpIDLSyn.o : BasicTypes.hi
+PpIDLSyn.o : Literal.hi
+PpIDLSyn.o : PP.hi
+PpIDLSyn.o : IDLSyn.hi
+PreProc.o : PreProc.lhs
+PreProc.o : Utils.hi
+PreProc.o : Opts.hi
+Pretty.o : Pretty.lhs
+Rename.o : Rename.lhs
+Rename.o : Literal.hi
+Rename.o : Opts.hi
+Rename.o : DsMonad.hi
+Rename.o : Utils.hi
+Rename.o : Attribute.hi
+Rename.o : CoreUtils.hi
+Rename.o : BasicTypes.hi
+Rename.o : CoreIDL.hi
+Rename.o : RnMonad.hi
+RnMonad.o : RnMonad.lhs
+RnMonad.o : Utils.hi
+RnMonad.o : BasicTypes.hi
+RnMonad.o : CoreUtils.hi
+RnMonad.o : CoreIDL.hi
+RnMonad.o : DsMonad.hi
+RnMonad.o : Env.hi
+Skeleton.o : Skeleton.lhs
+Skeleton.o : LibUtils.hi
+Skeleton.o : Attribute.hi
+Skeleton.o : CoreUtils.hi
+Skeleton.o : CoreIDL.hi
+Skeleton.o : AbsHUtils.hi
+Skeleton.o : MkImport.hi
+Skeleton.o : MarshallUtils.hi
+Skeleton.o : MarshallCore.hi
+Skeleton.o : AbstractH.hi
+SrcLoc.o : SrcLoc.lhs
+SrcLoc.o : PP.hi
+SymbolTable.o : SymbolTable.lhs
+SymbolTable.o : FiniteMap.hi
+TLBWriter.o : TLBWriter.lhs
+TLBWriter.o : TypeInfo.hi
+TLBWriter.o : Utils.hi
+TLBWriter.o : CoreUtils.hi
+TLBWriter.o : Literal.hi
+TLBWriter.o : Attribute.hi
+TLBWriter.o : PpCore.hi
+TLBWriter.o : BasicTypes.hi
+TLBWriter.o : CoreIDL.hi
+TypeInfo.o : TypeInfo.lhs
+TypeInfo.o : LibUtils.hi
+TypeInfo.o : AbstractH.hi
+TypeInfo.o : AbsHUtils.hi
+TypeInfo.o : Opts.hi
+TypeInfo.o : NativeInfo.hi
+TypeInfo.o : BasicTypes.hi
+Utils.o : Utils.lhs
+Validate.o : Validate.lhs
+Validate.o : Utils.hi
+Validate.o : TypeInfo.hi
+Validate.o : Opts.hi
+Validate.o : BasicTypes.hi
+Validate.o : CoreUtils.hi
+Validate.o : CoreIDL.hi
+CustomAttributes.o : CustomAttributes.hs
+CustomAttributes.o : BasicTypes.hi
+Parser.o : Parser.hs
+Parser.o : Literal.hi
+Parser.o : BasicTypes.hi
+Parser.o : IDLUtils.hi
+Parser.o : IDLSyn.hi
+Parser.o : IDLToken.hi
+Parser.o : Lex.hi
+Parser.o : LexM.hi
+Version.o : Version.hs
+OmgParser.o : OmgParser.hs
+OmgParser.o : Literal.hi
+OmgParser.o : BasicTypes.hi
+OmgParser.o : IDLSyn.hi
+OmgParser.o : IDLToken.hi
+OmgParser.o : Lex.hi
+OmgParser.o : LexM.hi
+NativeInfo.o : NativeInfo.hs
+# DO NOT DELETE: End of Haskell dependencies
+ src/AbsHUtils.lhs view
@@ -0,0 +1,1093 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Dec. 1st 2003  06:57  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Disjoint set of utilities for working with the @AbstractH@
+type.
+
+\begin{code}
+module AbsHUtils 
+	(
+	  tyConst
+	, tyQConst
+	, libTyQConst
+	, mkTyConst
+	, deTyCon
+	, tyCon
+	, tyQCon
+	, mkTyCon
+	, tyVar
+	, uniqueTyVar
+	, tyQVar
+	, isTyVar
+
+	, generaliseTys
+	, overloadedTyVar
+	, ctxtTyApp
+	, ctxtClass
+	, mbCtxtTyApp
+
+	, tyList
+	, tyMaybe
+	, tyVariant
+	, tuple
+	, tyInt8Name, tyInt16Name, tyInt32Name, tyInt64Name, tyIntName
+	, tyInt8, tyInt16, tyInt32, tyInt64, tyInt
+	, tyInteger, tyIntegerName
+	, tyFloat, tyDouble, tyLongDouble
+	, tyAddr
+	, tyPtr
+	, anyTyPtr
+	, tyFunPtr
+	, tyForeignObj
+	, tyForeignPtr
+	, isFOTy
+	, isPtrTy
+	, isVARIANTTy
+	, toPtrTy
+
+	, tyStable
+	, tyString
+	, tyWString
+	, tyByte, tyChar, tyWChar
+	, tyBool
+	, tyWord8Name, tyWord16Name, tyWord32Name, tyWord64Name
+	, tyWord8, tyWord16, tyWord32, tyWord64
+	, funTy
+	, funTys
+	, io
+	, io_unit
+	, tyUnit
+	, purifyType
+	, isIOTy
+
+	, recCon
+	, recConBanged
+	, conDecl
+	, recToConDecl
+
+	, dataTy
+	, newTy
+	, tySyn
+	, conDeclToCon
+	, conDeclToPat
+	, splitFunTys
+	, hInstance
+	, hClass
+
+	, groundTyVars
+	, unconstrainType
+
+	, andDecl
+	, andDecls
+	, emptyDecl
+	, comment
+	, isEmptyDecl
+	, cCode
+
+	, typeSig
+	, genTypeSig
+	, mkTypeSig
+	, funDef
+	, valDef
+	, methodDef
+	, guardedFunDef
+	, prim
+	, primcst
+	, fexport
+	, extLabel
+
+	, conPat
+	, patVar
+	, patRec
+	, qpatVar
+	, litPat
+	, varPat
+	, tuplePat
+	, exprToPat
+	, wildPat
+	, isVarPat
+
+	, ret
+	, genBind
+	, bind
+	, bind_
+	, var
+	, varName
+	, qvar
+	, lam
+	, lit
+	, integerLit
+	, dataConst
+	, dataCon
+	, funApp
+	, contApply
+	, funApply
+	, infixOp
+	, binOp
+	, unaryOp
+	, tup
+	, hList
+	, hCase
+	, hIf
+	, alt
+	, genAlt
+	, defaultAlt
+	, equals
+	, hLet
+	, hLets
+
+	, intLit
+	, stringLit
+
+	, addPtr
+	, castPtr
+	, nothing
+	, just
+	, unit
+
+	, prefix
+	, prefixApp
+	, appendStr
+
+	, isVarsEq
+	
+	, hModule
+	, hMeta
+	, cMeta
+	, hInclude
+
+	, hExport
+	, hImport
+	, hQImport
+	, ieModule
+	, ieValue
+	, ieClass
+	, ieType
+	, subst
+
+	, mkQVarName
+	, mkVarName
+	, mkConName
+	, mkQConName
+	, mkTyVar
+	, mkQTyVar
+	, mkQTyCon
+	
+	, mkIntTy
+	, mkCharTy
+	, mkFloatTy
+	
+	, findIncludes
+	
+	, mkTySig
+	, replaceTyVar
+
+	) where
+
+import AbstractH
+import Literal
+import BasicTypes
+import LibUtils
+import Opts    ( optIntsEverywhere, optIntAsWord
+	       , optIntIsInt, optLongLongIsInteger
+	       , optNoWideStrings
+	       )
+import Maybe   ( fromMaybe, isJust )
+import Char    ( isLower )
+import List    ( mapAccumL, intersperse )
+
+-- This should be the default, but older versions (e.g., Jan 98) of
+-- Hugs insist on this one..
+infixl 9 `andDecl`
+\end{code}
+
+\begin{code}
+tyConst :: String -> Type
+tyConst con = TyCon (mkQualName Nothing con)
+
+tyQConst :: Maybe String -> String -> Type
+tyQConst m con = TyCon (mkQTyCon m con)
+
+libTyQConst :: Maybe String -> Maybe String -> String -> Type
+libTyQConst ty_mod marshall_mod con = TyCon ((mkQTyCon marshall_mod con){qDefModule=ty_mod})
+
+libTyQName :: Maybe String -> Maybe String -> String -> QualName
+libTyQName ty_mod marshall_mod con = (mkQTyCon marshall_mod con){qDefModule=ty_mod}
+
+{-
+ Slightly magic in that it transforms
+ "Foo.Bar a" into a type application.
+-}
+mkTyConst :: QualName -> Type
+mkTyConst qv 
+  | not (isJust (qModule qv)) && 
+    isLower (head (qName qv))
+  = TyVar False (mkTyVar (qName qv))
+  | length args > 1 
+  = TyApply (TyCon (qv{qName=a})) (map ((TyVar False). mkTyVar) as)
+  | otherwise = TyCon qv
+ where
+  args@(a:as) = words (qName qv)
+
+deTyCon :: Type -> QualName
+deTyCon (TyCon c) = c
+deTyCon _         = error "AbsHUtils.deTyCon: expected a tycon"
+
+tyCon :: String -> [Type] -> Type
+tyCon con args = TyApply (TyCon (mkQualName Nothing con)) args
+
+tyQCon :: Maybe String -> String -> [Type] -> Type
+tyQCon ty_mod con args = TyApply (TyCon (mkQTyCon ty_mod con)) args
+
+mkTyCon :: QualName -> [Type] -> Type
+mkTyCon qv args = TyApply (TyCon qv) args
+
+tyVar :: String -> Type
+tyVar nm = TyVar False (mkTyVar nm)
+
+uniqueTyVar :: String -> Type
+uniqueTyVar nm = TyVar True (mkTyVar nm)
+
+overloadedTyVar :: ClassName -> String -> Type
+overloadedTyVar c_name tv = TyCtxt (CtxtClass c_name [tvar]) tvar
+  where
+   tvar = TyVar False (mkTyVar tv)
+
+ctxtClass :: ClassName -> [Type] -> Context
+ctxtClass c ts = CtxtClass c ts
+
+ctxtTyApp :: Context -> Type -> Type
+ctxtTyApp ctxt t = TyCtxt ctxt t
+
+mbCtxtTyApp :: Maybe Context -> Type -> Type
+mbCtxtTyApp Nothing t = t
+mbCtxtTyApp (Just c) t = TyCtxt c t
+
+tyQVar :: Maybe String -> String -> Type
+tyQVar ty_mod nm = TyVar False (mkQTyVar ty_mod nm)
+
+isTyVar :: Type -> Bool
+isTyVar (TyVar _ _) = True
+isTyVar _           = False
+
+isNonUniqTyVar :: Type -> Bool
+isNonUniqTyVar (TyVar False _) = True
+isNonUniqTyVar _               = False
+
+unconstrainType :: Type -> ([(Context,TyVar)], Type)
+unconstrainType tx = go [] tx
+ where
+   go acc t = 
+    case t of
+      TyApply f args  -> 
+		let
+		 (acc1, f')    = go acc f
+		 (acc2, args') = mapAccumL go acc1 args
+		in
+		(acc2, TyApply f' args')
+      TyTuple ts      -> 
+    		let
+		 (acc1, ts') = mapAccumL go acc ts
+		 in
+		 (acc1, TyTuple ts')
+      TyFun t1 t2     -> 
+		let
+		 (acc1, t1') = go acc  t1
+		 (acc2, t2') = go acc1 t2
+		in
+		(acc2, TyFun t1' t2')
+      TyList t1   ->
+    		let
+		 (acc1, t1') = go acc t1
+		in
+		(acc1, TyList t1')
+      TyCtxt ctxt t1@(TyVar _ tv) -> ((ctxt,tv):acc, t1)
+      _		    -> (acc, t)
+
+groundTyVars :: Type -> Type
+groundTyVars t =
+  case t of
+    TyVar{}         -> groundTyVar t
+    TyApply (TyCon tc) args | qName tc == "Maybe" -> TyApply (TyCon tc) (map groundTyVars args)
+    TyApply tc args -> TyApply tc (map groundTyVar args)
+    TyTuple ts      -> TyTuple (map groundTyVars ts)
+    TyFun t1 t2     -> TyFun (groundTyVars t1) (groundTyVars t2)
+    TyList t1       -> TyList (groundTyVars t1)
+    TyCtxt _ _      -> t
+    _		    -> t
+ where
+  groundTyVar ty
+    | isNonUniqTyVar ty = tyUnit
+    | otherwise         = 
+    	case ty of
+--	  TyApply (TyCon tc) args 
+--	    | qName tc == "Maybe" -> TyApply (TyCon tc) (map groundTyVars args)
+	  TyApply tc args -> TyApply tc (map groundTyVars args)
+	  TyFun t1 t2 -> TyFun (groundTyVars t1) (groundTyVars t2)
+	  _ -> ty
+
+renameTyVar :: String -> Type -> Type
+renameTyVar new_nm (TyVar x _) = TyVar x (mkTyVar new_nm)
+renameTyVar _ t = t
+
+replaceTyVar :: Type -> Type -> Type
+replaceTyVar newTy ty = 
+  case ty of
+    TyVar _ _ -> newTy
+    TyApply f args -> TyApply f (map (replaceTyVar newTy) args)
+    TyTuple ts -> TyTuple (map (replaceTyVar newTy) ts)
+    TyFun a b -> TyFun (replaceTyVar newTy a) (replaceTyVar newTy b)
+    _ -> ty
+
+{-
+ generaliseTys lifts out embedded contexts and renames
+ type variables so as to make them unique.
+-}
+generaliseTys :: [Type] -> ([Type], Maybe Context)
+generaliseTys tys = 
+  case (go nm_supply [] tys) of
+    (ts, []) -> (ts, Nothing)
+    (ts, ls) -> (ts, Just (CtxtTuple (reverse ls)))
+  where
+    nm_supply = map (\ x -> 'a':show x) [(0::Int)..]
+    
+    substCtxt s x (CtxtTuple ls)   = CtxtTuple (map (substCtxt s x) ls)
+    substCtxt s x (CtxtClass c ts) = CtxtClass c (map (substTyVar s x) ts)
+
+    substTyVar o_t x t =
+      case t of
+        TyVar fixed n | not fixed && n == x -> o_t
+	TyApply t1 ty_args -> TyApply t' ty_args'
+	  where
+	   (t':ty_args') = map (substTyVar o_t x) (t1:ty_args)
+        TyList t1  -> TyList  (substTyVar o_t x t1)    
+	TyTuple ts -> TyTuple (map (substTyVar o_t x) ts)
+	TyFun a b  -> TyFun   (substTyVar o_t x a)
+			      (substTyVar o_t x b)
+	TyCtxt c t1 -> TyCtxt (substCtxt o_t x c)
+			      (substTyVar o_t x t1)
+	_ -> t			      
+
+    go _ acc [] = ([], acc)
+    go supply@(s:ss) acc_ctxt (x:xs) =
+      case x of
+        TyVar fixed _ | not fixed ->
+	  let
+	    x'        = renameTyVar s x
+	    (xs',acc) = go ss acc_ctxt xs
+	  in
+	  (x' : xs', acc)
+	TyCtxt ctxt tv@(TyVar fixed n) | not fixed -> 
+	  let
+	    tv'   = renameTyVar s tv
+	    ctxt' = substCtxt tv' n ctxt
+	    (xs',acc) = go ss (ctxt' : acc_ctxt) xs
+	  in
+	  (tv' : xs', acc)
+	TyApply t ty_args ->
+	  let
+	   (ts, acc) = go supply acc_ctxt (t:ty_args++xs)
+	   (t':ty_args', rs) = splitAt (length ty_args + 1) ts
+          in
+	  (TyApply t' ty_args' : rs, acc)
+	TyList t   -> 
+	  let
+	   (t':xs', acc) = go supply acc_ctxt (t:xs)
+	  in
+	  (TyList t' : xs' , acc)
+        TyTuple tuple_tys ->
+	  let
+	   (ts, acc)  = go supply acc_ctxt (tuple_tys++xs)
+	   (tys', rs) = splitAt (length tuple_tys) ts
+          in
+	  (TyTuple tys' : rs, acc)
+
+	TyFun t1 t2 ->
+	  let
+	   (t1' : t2' : xs', acc) = go supply acc_ctxt (t1:t2:xs)
+          in
+	  (TyFun t1' t2' :  xs', acc)
+	_ -> 
+          let
+	   (xs', acc) = go supply acc_ctxt xs
+	  in
+	  (x:xs', acc)
+    go _ _ _ = error "generaliseTys"
+
+--
+-- [Foo a, Foo b, Foo a] ==> [Foo a0, Foo b, Foo a0]
+--
+{- I suspect this is no longer needed - leaving it out for now.
+relabelTypes :: [Type] -> [Type]
+relabelTypes ts = 
+  case (go supply [] ts) of 
+    (ts,_,_) -> ts
+  where
+    supply = map (\ x -> 'a':show x) [0..]
+
+    go s acc [] = ([],s,acc)
+    go supply@(s:ss) acc (x:xs) =
+      case x of
+        TyVar fixed v ->
+	  case lookup v acc of
+	    Nothing -> 
+		let (xs',s',acc') = go ss ((v,s):acc) xs in
+		((TyVar fixed (mkTyVar s)):xs',s',acc')
+	    Just tv -> 
+	        let (xs',s',acc') = go supply acc xs in
+		(TyVar fixed (mkTyVar tv) : xs',s',acc')
+        TyApply t tvs ->
+	    let
+	     ([t'], supply', acc')      = go supply acc [t]
+	     (tvs',supply'',  acc'')  = go supply' acc' tvs
+	     (xs', supply''', acc''') = go supply'' acc'' xs
+	    in
+	    (TyApply t' tvs' : xs', supply''', acc''')
+        TyTuple ts ->
+	    let
+	     (ts', supply', acc')   = go supply acc ts
+	     (xs', supply'', acc'') = go supply' acc' xs
+	    in
+	    (TyTuple ts' : xs', supply'', acc'')
+        TyList ts ->
+	    let
+	     ([ts'], supply', acc')   = go supply acc [ts]
+	     (xs', supply'', acc'') = go supply' acc' xs
+	    in
+	    (TyList ts' : xs', supply'', acc'')
+	TyFun f a ->
+	    let
+	     ([f'], supply', acc') = go supply acc [f]
+	     ([a'], supply'', acc'') = go supply' acc' [a]
+	     (xs', supply''', acc''') = go supply'' acc'' xs
+	    in
+	    ((TyFun f' a') : xs', supply''', acc''')
+	TyCtxt c t ->
+	    let
+	     ([t'], supply', acc') = go supply acc [t]
+	    in
+	    ([TyCtxt c t'], supply', acc')
+	_ -> 
+	    let
+	     (xs', ss , acc') = go supply acc xs
+	    in
+	    (x : xs', ss, acc')
+
+    go _ _ _ = error "relabelTypes"
+-}
+
+tyList :: Type -> Type
+tyList t = TyList t
+
+tyMaybe :: Type -> Type
+tyMaybe t = TyApply (TyCon maybeName) [t]
+
+tyVariant :: Type
+tyVariant = TyCon variantType
+
+tuple :: [Type] -> Type
+tuple []  = tyUnit
+tuple [t] = t
+tuple ts  = TyTuple ts
+
+tyInt8Name, tyInt16Name, tyInt32Name, tyInt64Name, tyIntName :: QualName
+(tyInt8Name, tyInt16Name, tyInt32Name, tyInt64Name)
+  | optIntsEverywhere = (tyIntName, tyIntName, tyIntName, tyIntName)
+  | otherwise         = 
+     ( libTyQName intLib hdirectLib "Int8"
+     , libTyQName intLib hdirectLib "Int16"
+     , libTyQName intLib hdirectLib "Int32"
+     , libTyQName intLib hdirectLib "Int64"
+     )
+
+tyInt8, tyInt16, tyInt32, tyInt64, tyInt :: Type
+tyInt8  = mkTyConst tyInt8Name
+tyInt16 = mkTyConst tyInt16Name
+tyInt32 = mkTyConst tyInt32Name
+tyInt64 = mkTyConst tyInt64Name
+
+tyIntName = libTyQName prelude hdirectLib "Int"
+tyInt     = mkTyConst tyIntName
+
+tyIntegerName :: QualName
+tyInteger :: Type
+tyIntegerName = libTyQName prelude hdirectLib "Integer"
+tyInteger = mkTyConst tyIntegerName
+
+tyAddr :: Type
+--tyAddr = libTyQConst addrLib hdirectLib "Addr"
+tyAddr = tyPtr tyUnit
+
+tyPtr :: Type -> Type
+tyPtr t = TyApply (libTyQConst ptrLib hdirectLib ptrName) [t]
+
+anyTyPtr :: Type
+anyTyPtr = tyPtr (uniqueTyVar "a")
+
+tyStable :: Type
+tyStable = mkTyCon (libTyQName foreignLib hdirectLib "StablePtr") [uniqueTyVar "a"]
+
+tyForeignObj :: Type
+tyForeignObj = tyForeignPtr tyUnit
+
+tyForeignPtr :: Type -> Type
+tyForeignPtr t = TyApply (libTyQConst foreignPtrLib hdirectLib foreignPtrName) [t]
+
+tyFunPtr :: Type -> Type
+tyFunPtr t = TyApply (libTyQConst ptrLib hdirectLib funPtrName) [t]
+
+isFOTy :: Type -> Bool
+isFOTy (TyApply (TyCon tc) _) = qName tc == foreignPtrName
+isFOTy _ = False
+
+isPtrTy :: Type -> Bool
+isPtrTy (TyApply (TyCon tc) _) = nm == ptrName || nm == foreignPtrName
+ where
+  nm = qName tc
+isPtrTy _ = False
+
+toPtrTy :: Type -> Type
+toPtrTy ty@(TyApply (TyCon tc) [t]) 
+ | qName tc == foreignPtrName = tyPtr (toPtrTy t)
+ | otherwise = ty
+toPtrTy (TyApply tc ts) = TyApply tc (map toPtrTy ts)
+toPtrTy t = t
+
+isVARIANTTy :: Type -> Bool
+isVARIANTTy (TyCon tc) = qName tc == "VARIANT"
+isVARIANTTy _ = False
+
+tyString :: Type
+tyString = tyQConst prelude stringName
+
+tyWString :: Type
+tyWString 
+  | optNoWideStrings = tyString
+  | otherwise        = tyQConst wStringLib "WideString"
+
+tyByte, tyBool, tyChar :: Type
+tyChar = libTyQConst prelude hdirectLib "Char"
+tyBool = libTyQConst prelude hdirectLib "Bool"
+tyByte = tyWord8
+
+tyWordName :: QualName
+tyWordName = mkQualName wordLib "Word"
+
+tyWord :: Type
+tyWord = mkTyConst (tyWordName{qModule=hdirectLib})
+
+tyWord8Name, tyWord16Name, tyWord32Name, tyWord64Name :: QualName
+(tyWord8Name, tyWord16Name, tyWord32Name, tyWord64Name)
+  | optIntsEverywhere && optIntAsWord = (tyIntName, tyIntName, tyIntName, tyIntName)
+  | otherwise =
+     ( libTyQName wordLib hdirectLib "Word8"
+     , libTyQName wordLib hdirectLib "Word16"
+     , libTyQName wordLib hdirectLib "Word32"
+     , libTyQName wordLib hdirectLib "Word64"
+     )
+
+tyWord8, tyWord16, tyWord32, tyWord64 :: Type
+tyWord8  = mkTyConst tyWord8Name
+tyWord16 = mkTyConst tyWord16Name
+tyWord32 = mkTyConst tyWord32Name
+tyWord64 = mkTyConst tyWord64Name
+
+tyWChar :: Type
+tyWChar = tyWord16
+
+tyFloat, tyDouble, tyLongDouble :: Type
+tyFloat      = libTyQConst prelude hdirectLib "Float"
+tyDouble     = libTyQConst prelude hdirectLib "Double"
+tyLongDouble = libTyQConst prelude hdirectLib "Double" -- best we can do at the mo'.
+
+\end{code}
+
+
+\begin{code}
+funTy :: Type -> Type -> Type
+funTy a b = TyFun a b
+
+funTys :: [Type] -> Type -> Type
+funTys ls res = foldr TyFun res ls
+
+io :: Type -> Type
+io x = tyQCon prelude "IO" [x]
+
+isIOTy :: Type -> Bool
+isIOTy (TyApply (TyCon q) _)
+   | qName q == "IO" && qModule q == Just "Prelude" = True
+isIOTy _					    = False
+
+purifyType :: Type -> Type
+purifyType (TyFun x y@TyFun{}) = TyFun x (purifyType y)
+purifyType t@(TyFun x y) 
+ | isIOTy y = case y of { (TyApply _ [arg]) -> TyFun x arg ; _ -> t}
+purifyType t = t
+
+io_unit :: Type
+io_unit = io tyUnit
+
+tyUnit :: Type
+tyUnit = tyConst "()"
+\end{code}
+
+Constructor decls:
+
+\begin{code}
+recCon :: Name -> [(Name, Type)] -> ConDecl
+recCon nm fields = RecDecl nm (map (\ (x,t) -> (x,Unbanged t)) fields)
+
+recConBanged :: Name -> [(Name, Type)] -> ConDecl
+recConBanged nm fields = RecDecl nm (map (\ (x,t) -> (x,Banged t)) fields)
+
+conDecl :: Name -> [Type] -> ConDecl
+conDecl nm ls = ConDecl nm (map Unbanged ls)
+
+recToConDecl :: ConDecl -> ConDecl
+recToConDecl (RecDecl nm fs) = ConDecl nm (map snd fs)
+recToConDecl c = c
+
+dataTy :: Name -> [Name] -> [ConDecl] -> HDecl
+dataTy dname tvs constrs = TyD (TyDecl Data dname tvs constrs [])
+
+newTy :: Name -> [Name] -> ConDecl -> [QualName] -> HDecl
+newTy dname tvs constr ls = TyD (TyDecl Newtype dname tvs [constr] ls)
+
+hInstance :: Maybe [(ClassName,[TyVar])] -> ClassName -> Type -> [HDecl] -> HDecl
+hInstance Nothing cname t decls   = Instance (CtxtTuple []) cname t decls
+hInstance (Just ls) cname t decls = 
+   Instance (CtxtTuple (map (uncurry (\ x y -> CtxtClass x (map (TyVar False) y))) ls)) cname t decls
+
+hClass :: Context -> ClassName -> [TyVar] -> [HDecl] -> HDecl
+hClass ctxt nm tvs ds = Class ctxt nm tvs ds 
+
+--unparameterised type synonym.
+tySyn :: Name -> [Name] -> Type  -> HDecl
+tySyn dname tvs ty = TyD (TypeSyn dname tvs ty)
+
+
+-- (Foo T1 T2 T3) ==> (Foo a1 a2 a3)
+-- (Foo {f1::T1,f2::T2}) ==> (Foo f1 f2)
+conDeclToCon :: ConDecl -> Expr
+conDeclToCon (ConDecl nm args)   = 
+  dataCon (mkConName nm) (zipWith (\ _ a -> var ('a':show a)) args [(1::Int)..])
+conDeclToCon (RecDecl nm fields) = 
+  dataCon (mkConName nm) (map (\ (f,_) -> var f) fields)
+
+conDeclToPat :: ConDecl -> Pat
+conDeclToPat (ConDecl nm args)   = 
+  conPat (mkConName nm) (zipWith (\ _ a -> patVar ('a':show a)) args [(1::Int)..])
+conDeclToPat (RecDecl nm fields) = 
+  conPat (mkConName nm) (map (\ (f,_) -> patVar f) fields)
+
+-- prelude/Type.lhs rip-off
+splitFunTys :: Type -> ([Type], Type)
+splitFunTys ty = split [] ty ty
+ where
+  split args _       (TyFun arg res) = split (arg:args) res res
+  split args orig_ty _               = (reverse args, orig_ty)
+\end{code}
+
+\begin{code}
+andDecl :: HDecl -> HDecl -> HDecl
+andDecl = AndDecl
+
+andDecls :: [HDecl] -> HDecl
+andDecls = foldr (andDecl) emptyDecl
+
+isEmptyDecl :: HDecl -> Bool
+isEmptyDecl EmptyDecl = True
+isEmptyDecl _	      = False
+
+emptyDecl :: HDecl
+emptyDecl = EmptyDecl
+
+comment :: String -> HDecl
+comment str = Haskell ('-':'-':' ':str)
+
+cCode :: String -> HDecl
+cCode s = CCode s
+\end{code}
+
+\begin{code}
+typeSig :: String -> Type -> HDecl
+typeSig nm ty = TypeSig nm Nothing ty
+
+genTypeSig :: String -> Maybe Context -> Type -> HDecl
+genTypeSig nm mb_ctxt ty = TypeSig nm mb_ctxt ty
+
+-- hoists out the contexts before constructing the tysig.
+mkTypeSig :: String -> [Type] -> Type -> HDecl
+mkTypeSig nm pts rty = genTypeSig nm ctxt (foldr funTy rty' pts')
+ where
+   (rty':pts', ctxt) = generaliseTys (rty:pts)
+
+funDef :: String -> [Pat] -> Expr -> HDecl 
+funDef nm pats rhs = ValDecl (mkVarName nm) pats [GExpr [] rhs]
+
+valDef :: String -> Expr -> HDecl
+valDef nm rhs = ValDecl (mkVarName nm) [] [GExpr [] rhs]
+
+methodDef :: QualName -> [Pat] -> Expr -> HDecl 
+methodDef qnm pats rhs = ValDecl qnm pats [GExpr [] rhs]
+
+guardedFunDef :: String -> [Pat] -> [(Expr,Expr)] -> HDecl
+guardedFunDef nm pats grhs = ValDecl (mkVarName nm) pats (map (\ (g,e) -> GExpr [g] e) grhs)
+
+prim :: CallConv -> LocSpec -> Name -> Type -> Bool -> [(Bool,String)] -> (Bool,String) -> HDecl
+prim cc ls nm ty need_wrapper c_args c_res 
+  = Primitive True cc ls nm ty need_wrapper c_args c_res
+
+extLabel :: Name -> Name -> Type -> HDecl
+extLabel cname hname t = ExtLabel cname hname t
+
+primcst :: CallConv -> Name -> Type -> Bool -> [(Bool,String)] -> (Bool,String) -> HDecl
+primcst cc nm ty need_wrapper c_args c_res 
+  = PrimCast cc nm ty need_wrapper c_args c_res
+
+fexport :: CallConv -> Maybe Name -> Name -> Type -> HDecl
+fexport cc Nothing     h_nm ty = Callback cc h_nm ty
+fexport cc (Just c_nm) h_nm ty = Entry cc c_nm h_nm ty
+\end{code}
+
+\begin{code}
+conPat :: ConName -> [Pat] -> Pat
+conPat dc a = PatCon dc a
+
+patVar :: Name -> Pat
+patVar v = PatVar (mkVarName v)
+
+isVarPat :: Pat -> Bool
+isVarPat (PatVar _) = True
+isVarPat _	    = False
+
+wildPat :: Pat
+wildPat = PatWildCard
+
+patRec :: VarName -> [(VarName, Pat)] -> Pat
+patRec nm pats = PatRecord nm pats
+
+qpatVar :: Maybe String -> Name -> Pat
+qpatVar qmod v = PatVar (mkQVarName qmod v)
+
+varPat :: Expr -> Pat
+varPat (Var v) = PatVar v
+varPat _       = error "varPat: no can do - wasn't passed a Var, guv."
+
+litPat :: Literal -> Pat
+litPat l = PatLit l
+
+tuplePat :: [Pat] -> Pat
+tuplePat [p] = p
+tuplePat ps  = PatTuple ps
+
+exprToPat :: Expr -> Maybe Pat
+exprToPat (Var v)   = Just (PatVar v)
+exprToPat (Con c)   = Just (PatCon c [])
+exprToPat (Apply (Con c) ls) = Just (PatCon c (map ((fromMaybe PatWildCard).exprToPat) ls))
+exprToPat (Lit l)   = Just (PatLit l)
+exprToPat (List ls) = Just (PatList  (map ((fromMaybe PatWildCard).exprToPat) ls))
+exprToPat (Tup ls)  = Just (tuplePat (map ((fromMaybe PatWildCard).exprToPat) ls))
+exprToPat _	    = Nothing
+\end{code}
+
+Expressions:
+
+\begin{code}
+ret :: Expr -> Expr
+ret e = Return e
+
+bind :: Expr -> Expr -> Expr -> Expr
+bind m v n = Bind m (varPat v) n
+
+genBind :: Expr -> Pat -> Expr -> Expr
+genBind m p n = Bind m p n
+
+bind_ :: Expr -> Expr -> Expr
+bind_ m n = Bind_ m n
+
+var :: Name -> Expr
+var v = Var (mkVarName v)
+
+varName :: VarName -> Expr
+varName v = Var v
+
+qvar :: Maybe String -> Name -> Expr
+qvar qmod v = Var (mkQVarName qmod v)
+
+lam :: [Pat] -> Expr -> Expr
+lam pats e = Lam pats e
+
+lit :: Literal -> Expr
+lit l = Lit l
+
+integerLit :: IntegerLit -> Expr
+integerLit l = Lit (IntegerLit l)
+
+dataConst :: ConName -> Expr
+dataConst nm = Con nm
+
+dataCon :: ConName -> [Expr] -> Expr
+dataCon dc args = Apply (Con dc) args
+
+funApp :: VarName -> [Expr] -> Expr
+funApp f args = Apply (Var f) args
+
+-- right-assoc function application.
+contApply :: Expr -> Expr -> Expr
+contApply e1 e2 = RApply e1 e2
+
+funApply :: Expr -> [Expr] -> Expr
+funApply f args = Apply f args
+
+binOp :: BinaryOp -> Expr -> Expr -> Expr
+binOp bop e1 e2 = BinOp bop e1 e2
+
+infixOp :: Expr -> VarName -> Expr -> Expr
+infixOp e1 op e2 = InfixOp e1 op e2
+
+unaryOp :: UnaryOp -> Expr -> Expr
+unaryOp uop e1 = UnOp uop e1
+
+tup :: [Expr] -> Expr
+tup [e] = e
+tup es = Tup es
+
+hList :: [Expr] -> Expr
+hList es = List es
+
+hCase :: Expr -> [CaseAlt] -> Expr
+hCase scrut alts = Case scrut alts
+
+hIf :: Expr -> Expr -> Expr -> Expr
+hIf c e1 e2 = If c e1 e2
+
+alt :: Pat -> Expr -> CaseAlt
+alt p e = Alt p [GExpr [] e]
+
+genAlt :: Pat -> Expr -> Expr -> CaseAlt
+genAlt p g e = Alt p [GExpr [g] e]
+
+defaultAlt :: (Maybe VarName) -> Expr -> CaseAlt
+defaultAlt b e = Default b e
+
+equals :: Expr -> Expr -> Binding
+equals (Var v) e = Binder (qName v) e
+equals _       _ = error "equals: no can do - wasn't passed a Var, guv."
+
+hLet :: Expr{-a Var-} -> Expr -> Expr -> Expr
+hLet v x y = Let [(equals v x)] y
+
+hLets :: [(Expr,Expr)] -> Expr -> Expr
+hLets bs e = Let (map (uncurry equals) bs) e
+
+intLit :: Integral a => a -> Expr
+intLit v = Lit (IntegerLit (ILit 10 (toInteger v)))
+
+stringLit :: String -> Expr
+stringLit v = Lit (StringLit v)
+
+addPtr :: Expr -> Expr -> Expr
+addPtr ptr off = funApp (mkQVarName hdirectLib "addNCastPtr") [ptr, off]
+
+castPtr :: Expr -> Expr
+castPtr ptr = funApp castPtrName [ptr]
+
+nothing :: Expr
+nothing = dataConst nothingName
+
+just :: Expr -> Expr
+just v = dataCon justName [v]
+
+unit :: Expr
+unit = tup [] --dataConst (mkConName "()")
+
+prefix :: String -> TyCon -> VarName
+prefix = prefixQName
+
+prefixApp :: String -> TyCon -> VarName
+prefixApp = prefixAppQName
+
+appendStr :: String -> TyCon -> VarName
+appendStr v tname = tname{qName=qName tname ++ v, qDefModule=Nothing}
+
+isVarsEq :: Expr -> Expr -> Bool
+isVarsEq (Var a) (Var b) = qName a == qName b
+isVarsEq _       _       = error "isVarsEq"
+
+\end{code}
+
+Misc toplevel decls
+
+\begin{code}
+hModule :: Name -> Bool -> [HExport] -> [HImport] -> HDecl -> HTopDecl
+hModule nm flg exps imps d = HMod (HModule nm flg exps imps d)
+
+hMeta   :: String -> HTopDecl
+hMeta str = HLit str
+
+cMeta   :: String -> HTopDecl
+cMeta str = CLit str
+
+hInclude   :: String -> HTopDecl
+hInclude str = HInclude str
+
+hExport  :: HIEEntity -> Maybe String -> HExport
+hExport ent comment_ = HExport ent comment_
+
+hImport  :: Name -> Bool -> [HIEEntity] -> HImport
+hImport nm is_qualed ls =
+ HImport is_qualed Nothing nm $
+ case ls of
+   [] -> Nothing
+   _  -> Just ls
+
+hQImport :: Name -> Maybe Name -> [HIEEntity] -> HImport
+hQImport nm maybeAs stuff = HImport True maybeAs nm (Just stuff)
+
+ieModule, ieValue, ieClass :: Name -> HIEEntity
+ieModule nm = IEModule nm
+ieValue  nm = IEVal    nm
+ieClass  nm = IEClass  nm
+
+ieType :: Name -> Bool -> HIEEntity
+ieType nm abstractly = IEType nm abstractly
+\end{code}
+
+
+\begin{code}
+subst :: Name -> Expr -> Expr -> Expr
+subst nm e1 e2 = go e2
+  where
+   go e@(Var v)
+      | qName v == nm = e1
+      | otherwise     = e
+   go e@(Con _)    = e
+   go e@(Lit _)    = e
+    -- don't worry about capture..yet.
+   go (Lam pats e) = Lam pats (go e)
+   go (Apply f args) = Apply (go f) (map go args)
+   go (RApply f x) = RApply (go f) (go x)
+   go (Tup es) = Tup (map go es)
+   go (BinOp op e_1 e_2) = BinOp op (go e_1) (go e_2)
+   go (UnOp op e) = UnOp op (go e)
+   go (Bind e_1 p e_2) = Bind (go e_1) p (go e_2)
+   go (Bind_ e_1 e_2) = Bind_ (go e_1) (go e_2)
+   go (List es) = List (map go es)
+   go (InfixOp op qnm e) = InfixOp op qnm (go e)
+   go (Return e) = Return (go e)
+   go (Case e alts) = Case (go e) (map substAlt alts)
+   go (If e_1 e_2 e_3) = If (go e_1) (go e_2) (go e_3)
+   go (Let binds e) = Let binds (go e)
+   go (WithTy e ty) = WithTy (go e) ty
+
+   substAlt (Alt p gs)     = Alt p (map (\ (GExpr ls e) -> GExpr (map go ls) (go e)) gs)
+   substAlt (Default mb e) = Default mb (go e)
+
+\end{code}
+
+\begin{code}
+mkQVarName :: Maybe String -> String -> VarName
+mkQVarName qmod nm = mkQualName qmod nm
+
+mkVarName :: String -> VarName
+mkVarName nm = mkQualName Nothing nm
+
+mkConName :: String -> ConName
+mkConName nm = mkQualName Nothing nm
+
+mkQConName :: Maybe String -> String -> ConName
+mkQConName qmod nm = mkQualName qmod nm
+
+mkTyVar :: String -> TyVar
+mkTyVar nm = mkQualName Nothing nm
+
+mkQTyVar :: Maybe String -> String -> TyVar
+mkQTyVar qmod nm = mkQualName qmod nm
+
+mkQTyCon :: Maybe String -> String -> TyCon
+mkQTyCon qmod nm = mkQualName qmod nm
+\end{code}
+
+
+
+Generating a corresponding int type. Slightly awkward expressed, so
+that we can easily retarget the mapping (and home) for the various
+numeric types in AbsHUtils.
+
+\begin{code}
+type Signed = Bool
+
+mkIntTy :: Size -> Signed -> Type
+mkIntTy sz isSigned
+  | isSigned =
+      case sz of
+         Short    -> tyInt16
+	 Long     -> tyInt32
+	 Natural
+	  | optIntIsInt -> tyInt
+	  | otherwise   -> tyInt32
+
+	 LongLong 
+	    | optLongLongIsInteger -> tyInteger
+	    | otherwise            -> tyInt64
+  | otherwise =
+      case sz of 
+         Short    -> tyWord16
+	 Long     -> tyWord32
+	 Natural
+	  | optIntIsInt -> tyWord
+	  | otherwise   -> tyWord32
+	 LongLong 
+	  | optLongLongIsInteger -> tyInteger
+	  | otherwise		 -> tyWord64
+\end{code}
+
+
+Mapping for floats and chars       
+
+\begin{code}
+mkFloatTy :: Size -> Type
+mkFloatTy sz =
+  case sz of 
+    Short    -> tyFloat
+    Long     -> tyDouble
+    LongLong -> tyLongDouble
+    Natural  -> tyFloat
+
+mkCharTy :: Signed -> Type
+mkCharTy isSigned
+ | isSigned  = tyInt8
+ | otherwise = tyChar
+\end{code}
+
+\begin{code}
+findIncludes :: HDecl -> [String]
+findIncludes d = whizz d []
+ where
+  whizz (AndDecl h1 h2) rs = whizz h1 (whizz h2 rs)
+  whizz (Include x)     rs = x:rs
+  whizz _		rs = rs
+
+\end{code}
+
+\begin{code}
+mkTySig :: [Type] -> Type -> String
+mkTySig ps res = concat (intersperse "-" ls)
+ where
+   ls = map toSig (ps ++ [res])
+   toSig (TyCon tc) = 
+      case qName tc of
+        'I':'n':'t':xs -> 'I':xs 
+        'W':'o':'r':'d':xs -> 'W':xs 
+	v -> v
+   toSig (TyVar _ tv) = qName tv
+   toSig (TyApply tc@TyCon{} ts) = concatMap toSig (tc:ts)
+    -- weaken once debugged.
+   toSig _ = error "mkTySig: not supposed to happen"
+
+\end{code}
+ src/AbstractH.lhs view
@@ -0,0 +1,218 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 8th 2003  06:45  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+A (restricted) abstract syntax for Haskell.
+
+\begin{code}
+module AbstractH where
+
+import Literal
+import BasicTypes
+\end{code}
+
+The @HTopDecl@ includes Haskell modules, but also
+an escape mechanism for inserting stuff that goes
+outside it (literate markup/pragmas etc.)
+
+\begin{code}
+data HTopDecl
+ = HMod     HModule
+ | HInclude String
+ | HLit     String  -- ToDo: nuke.
+ | CLit     String
+     -- literal code/comments/whatever that appears outside a module block.
+\end{code}
+
+Represent a Haskell module abstractly by @HModule@, which
+
+\begin{code}
+data HModule = 
+  HModule
+    Name
+    Bool    -- True => module contains FFI declarations (of some sort).
+    [HExport]
+    [HImport]
+    HDecl
+\end{code}
+
+\begin{code}
+data HExport = HExport HIEEntity (Maybe String)
+
+data HIEEntity
+ = IEModule Name
+ | IEVal    Name
+ | IEClass  Name
+ | IEType   Name Bool{-abstractly?-}
+ deriving Eq
+\end{code}
+
+\begin{code}
+data HImport 
+  = HImport 
+      Bool		    --qualified?
+      (Maybe Name)	    --qualify as
+      Name		    --module name
+      (Maybe [HIEEntity])   -- stuff to import, 
+			    --   Nothing => the lot.
+			    --   Just [] => ()  (i.e., bring instances into scope.)
+\end{code}
+
+
+\begin{code}
+data HDecl 
+ = AndDecl HDecl HDecl  -- for easy glomming together
+			-- of code fragments.
+ 
+    -- function signature foo :: ctxt => type
+ | TypeSig  Name (Maybe Context) Type  
+
+    -- f a1 .. an 
+    --   | g_1 = rhs_1
+    --     ...
+    --   | g_n = rhs_n
+    --
+    --
+    -- Note: allow qualified names here, which is
+    -- illegal for toplevel valdecls in Haskell, but
+    -- required (by Haskell 98 and ghc) for class
+    -- methods in instance decls if the module that
+    -- defines the class is imported qualified.
+    -- (Unfortunately, Hugs does not currently allow
+    -- said qualified method names, so a separate option
+    -- is provided for turning off the use of qualified
+    -- names on valdecls.)
+ | ValDecl  QualName [Pat] [GuardedExpr]
+
+    -- primitive stdcall ["winmm.TimeGetTime"] [safe] timeGetTime :: ty
+ | Primitive Bool{-safe?-} CallConv LocSpec Name Type Bool [(Bool,String)] (Bool,String)
+
+    -- primcast stdcall applyIntFun :: Addr -> (Int -> IO Int)
+ | PrimCast CallConv Name Type Bool [(Bool,String)] (Bool,String)
+
+    -- entry stdcall ["tmgtm"] timeGetTime :: ty
+ | Entry CallConv Name{-C name-} Name{-H name-} Type
+
+    -- callback stdcall mkIntFun :: (Int -> IO Int) -> IO Addr
+ | Callback CallConv Name Type
+ 
+    -- 'foreign label'
+ | ExtLabel Name{-C name-} Name{-H name-} Type
+    -- (type|newtype|data) Nm a1..an = ty
+ | TyD TyDecl
+
+    -- class ctxt    => CName a1 [..an] where { decls }
+ | Class Context ClassName [TyVar] [HDecl] -- sigs and def. meths
+
+    -- instance ctxt => CName ty where { .. decls .. }
+ | Instance Context ClassName Type [HDecl] -- val decls only.
+
+    -- %#include "foo" or {-# OPTIONS -#include "foo" #-}
+ | Include String -- ghc/gc specific - will disappear eventually.
+
+ | Haskell String -- Haskell code brought along from source file.
+ | CCode   String -- C code
+
+ | EmptyDecl
+
+type LocSpec = (String, Maybe Integer, String, Maybe Int)
+
+type ClassName = QualName
+
+data Context
+ = CtxtTuple [Context]   -- (C1 .., C2 ..) =>
+ | CtxtClass ClassName [Type]
+   deriving ( Eq, Show )
+\end{code}
+
+@Type@ represent Haskell types - no explicit
+management of the scoping of type variables.
+
+\begin{code}
+data Type
+ = TyVar   Bool TyVar
+ | TyCon   TyCon 
+ | TyApply Type [Type]
+ | TyList  Type
+ | TyTuple [Type]
+ | TyFun   Type Type
+    -- abstract syntax allows contexts to be added to any types - makes
+    -- generation of overloaded tysigs easier.
+ | TyCtxt  Context Type
+   deriving ( Eq, Show ) 
+\end{code}
+
+Patterned on @HsDecls.TyDecl@ (no support for
+tycon contexts tho')
+
+\begin{code}
+data TyDecl
+ = TypeSyn Name [Name] Type
+ | TyDecl TyDeclKind
+	  Name          -- type constructor
+	  [Name]        -- type vars
+	  [ConDecl]     -- data constructors
+	  [QualName]    -- derivings
+
+
+data TyDeclKind = Data | Newtype
+
+data ConDecl
+ = ConDecl Name [BangType]
+ | RecDecl Name [(Name, BangType)]
+
+data BangType = Banged Type | Unbanged Type
+
+type TyVar = QualName
+type TyCon = QualName
+\end{code}
+
+\begin{code}
+data GuardedExpr = GExpr [Expr] Expr
+
+data Expr
+ = Lit    Literal
+ | Lam    [Pat] Expr
+ | Apply Expr [Expr]
+ | RApply Expr Expr
+ | Tup    [Expr]
+ | List   [Expr]
+ | InfixOp Expr VarName Expr
+ | BinOp  BinaryOp Expr Expr
+ | UnOp   UnaryOp  Expr
+ | Bind   Expr Pat Expr
+ | Bind_  Expr Expr
+ | Return Expr
+ | Case   Expr [CaseAlt]
+ | If     Expr Expr Expr
+ | Let    [Binding] Expr
+ | Var    VarName
+ | Con    ConName
+ | WithTy Expr Type
+
+data Binding = Binder Name Expr
+
+type VarName = QualName
+type ConName = QualName
+
+\end{code}
+
+\begin{code}
+data Pat
+ = PatVar VarName
+ | PatLit Literal
+ | PatWildCard
+ | PatTuple [Pat]
+ | PatAs   VarName Pat
+ | PatCon  ConName [Pat]
+ | PatList [Pat]
+ | PatIrrefut Pat
+ | PatRecord VarName [(VarName,Pat)]
+
+data CaseAlt
+ = Alt Pat [GuardedExpr]
+ | Default (Maybe VarName) Expr
+\end{code}
+ src/Attribute.lhs view
@@ -0,0 +1,164 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 9th 2003  14:48  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Operations on attributes, the <tt/Attribute/ type itself
+is defined in <tt/CoreIDL/ 
+
+\begin{code}
+module Attribute where
+
+import BasicTypes
+import Literal
+import CoreIDL
+import List  ( find )
+import Utils ( elemBy, mapMb, notNull )
+import Maybe ( mapMaybe )
+
+\end{code}
+
+\begin{code}
+noAttrs :: [Attribute]
+noAttrs = []
+
+hasAttribute :: [Attribute] -> Attribute -> Bool
+hasAttribute attrs attr = attr `elem` attrs
+
+hasAttributeWithName :: [Attribute] -> Name -> Bool
+hasAttributeWithName attrs nm = elemBy lup attrs
+ where
+  lup (Attribute n _) = n == nm
+  lup _		      = False
+
+hasAttributeWithNames :: [Attribute] -> [Name] -> Bool
+hasAttributeWithNames attrs nms = elemBy lup attrs
+ where
+  lup (Attribute n _) = n `elem` nms
+  lup _		      = False
+
+-- return list of attributes that haven't got any of the names given in the list.
+filterOutAttributes :: [Attribute] -> [Name] -> [Attribute]
+filterOutAttributes attrs nms = filter out attrs
+  where
+   out (Attribute n _) = not (n `elem` nms)
+   out _	       = True
+
+-- return list of attributes that have got one of the names given in the list.
+filterAttributes :: [Attribute] -> [Name] -> [Attribute]
+filterAttributes attrs nms = filter predic attrs
+  where
+   predic (Attribute n _) = n `elem` nms
+   predic _	          = False
+
+findAttribute :: Name -> [Attribute] -> Maybe Attribute
+findAttribute nm attrs = find lup attrs
+ where
+  lup (Attribute n _) = n == nm
+  lup _		      = False
+
+findStringAttributes :: Name -> [Attribute] -> [String]
+findStringAttributes nm = mapMaybe toString . filter lup
+ where
+  lup (Attribute n _) = n == nm
+  lup _		      = False
+
+  toString (Attribute _ [ParamLit (StringLit s)]) = Just s
+  toString _ = Nothing
+
+\end{code}
+
+\begin{code}
+isDependentAttribute :: Attribute -> Maybe Attribute
+isDependentAttribute a@(AttrDependent _ _) = Just a
+isDependentAttribute _			   = Nothing
+
+isConstantAttribute :: Attribute -> Bool
+isConstantAttribute (AttrMode _) = True
+isConstantAttribute a		 = null (atParams a)
+
+stringToDepReason :: String -> Maybe DepReason
+stringToDepReason "size_is"   = Just SizeIs
+stringToDepReason "first_is"  = Just FirstIs
+stringToDepReason "last_is"   = Just LastIs
+stringToDepReason "length_is" = Just LengthIs
+stringToDepReason "max_is"    = Just MaxIs
+stringToDepReason "min_is"    = Just MinIs
+stringToDepReason "switch_is" = Just SwitchIs
+stringToDepReason _	      = Nothing
+\end{code}
+
+Special purpose ones:
+
+\begin{code}
+hasStringAttribute :: [Attribute] -> Bool
+hasStringAttribute attrs = hasAttributeWithName attrs "string"
+
+hasSeqAttribute :: [Attribute] -> Bool
+hasSeqAttribute attrs = hasAttributeWithName attrs "sequence"
+
+hasSourceAttribute :: [Attribute] -> Bool
+hasSourceAttribute attrs = hasAttributeWithName attrs "source"
+
+hasUniqueAttribute :: [Attribute] -> Bool
+hasUniqueAttribute attrs = hasAttributeWithName attrs "unique"
+
+getLengthAttribute :: [Attribute] -> Maybe AttributeParam
+getLengthAttribute attrs = 
+   case (filter withDep attrs) of
+     (AttrDependent _ (x:_) : _) -> Just x
+     _ -> Nothing
+  where
+   withDep (AttrDependent LengthIs _) = True
+   withDep _		 = False
+
+
+hasModeAttribute :: ParamDir -> [Attribute] -> Bool
+hasModeAttribute dir attrs = any withMode attrs
+  where
+   withMode (AttrMode d) = d == dir
+   withMode _		 = False
+
+getSwitchIsAttribute :: [Attribute] -> Maybe Expr
+getSwitchIsAttribute as = 
+  case mapMb atParams (findAttribute "switch_is" as) of
+    Just [ParamExpr e]          -> Just e
+    Just [ParamVar v]		-> Just (Var v)
+    _ ->
+      case filter (isSwitchIs) as of
+        ((AttrDependent _ [ParamVar v]): _ )  -> Just (Var v)
+        ((AttrDependent _ [ParamExpr e]): _ ) -> Just e
+	_				      -> Nothing
+ where
+  isSwitchIs (AttrDependent SwitchIs _) = True
+  isSwitchIs _				= False
+
+getUuidAttribute :: [Attribute] -> Maybe [String]
+getUuidAttribute as =
+ case mapMb atParams (findAttribute "uuid" as) of
+   Just [ParamLit (GuidLit guid)] -> Just guid
+   Just [ParamLit (LitLit  guid)] -> Just [guid]
+   _ -> Nothing
+
+getDispIdAttribute :: [Attribute] -> Maybe IntegerLit
+getDispIdAttribute as =
+ case mapMb atParams (findAttribute "id" as) of
+   Just [ParamLit (IntegerLit i)] -> Just i
+   _ -> Nothing
+
+hasDependentAttrs :: [Attribute] -> Bool
+hasDependentAttrs ls = notNull (mapMaybe isDependentAttribute ls)
+
+sourceAttribute :: Attribute
+sourceAttribute = Attribute "source" []
+
+getDefaultCConv :: [Attribute] -> Maybe CallConv
+getDefaultCConv as = 
+  case mapMb atParams (findAttribute "cconv" as) of
+   Just [ParamLit (StringLit cc)] -> strToCallConv cc
+   _			          -> Nothing
+
+\end{code}
+
+ src/Bag.lhs view
@@ -0,0 +1,148 @@+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[Bags]{@Bag@: an unordered collection with duplicates}
+
+\begin{code}
+module Bag (
+	Bag,	-- abstract type
+
+	emptyBag, unitBag, unionBags, unionManyBags,
+	mapBag,
+	elemBag,
+
+	filterBag, partitionBag, concatBag, foldBag,
+	isEmptyBag, consBag, snocBag,
+	listToBag, bagToList
+    ) where
+
+import List(partition)
+
+data Bag a
+  = EmptyBag
+  | UnitBag	a
+  | TwoBags	(Bag a) (Bag a)	-- The ADT guarantees that at least
+				-- one branch is non-empty
+  | ListBag	[a]		-- The list is non-empty
+  | ListOfBags	[Bag a]		-- The list is non-empty
+
+emptyBag :: Bag a
+emptyBag = EmptyBag
+
+unitBag :: a -> Bag a
+unitBag  = UnitBag
+
+elemBag :: Eq a => a -> Bag a -> Bool
+elemBag _ EmptyBag        = False
+elemBag x (UnitBag y)     = x==y
+elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
+elemBag x (ListBag ys)    = any (x ==) ys
+elemBag x (ListOfBags bs) = any (x `elemBag`) bs
+
+unionManyBags :: [Bag a] -> Bag a
+unionManyBags [] = EmptyBag
+unionManyBags xs = ListOfBags xs
+
+-- This one is a bit stricter! The bag will get completely evaluated.
+unionBags :: Bag a -> Bag a -> Bag a
+unionBags EmptyBag b = b
+unionBags b EmptyBag = b
+unionBags b1 b2      = TwoBags b1 b2
+
+consBag :: a -> Bag a -> Bag a
+snocBag :: Bag a -> a -> Bag a
+
+consBag elt bag = (unitBag elt) `unionBags` bag
+snocBag bag elt = bag `unionBags` (unitBag elt)
+
+isEmptyBag :: Bag a -> Bool
+isEmptyBag EmptyBag	    = True
+isEmptyBag (UnitBag _)	    = False
+isEmptyBag (TwoBags b1 b2)  = isEmptyBag b1 && isEmptyBag b2	-- Paranoid, but safe
+isEmptyBag (ListBag xs)     = null xs				-- Paranoid, but safe
+isEmptyBag (ListOfBags bs)  = all isEmptyBag bs
+
+filterBag :: (a -> Bool) -> Bag a -> Bag a
+filterBag _ EmptyBag = EmptyBag
+filterBag predic b@(UnitBag val) = if predic val then b else EmptyBag
+filterBag predic (TwoBags b1 b2) = sat1 `unionBags` sat2
+			       where
+				 sat1 = filterBag predic b1
+				 sat2 = filterBag predic b2
+filterBag predic (ListBag vs)    = listToBag (filter predic vs)
+filterBag predic (ListOfBags bs) = ListOfBags sats
+				where
+				 sats = [filterBag predic b | b <- bs]
+
+concatBag :: Bag (Bag a) -> Bag a
+
+concatBag EmptyBag 	    = EmptyBag
+concatBag (UnitBag b)       = b
+concatBag (TwoBags b1 b2)   = concatBag b1 `TwoBags` concatBag b2
+concatBag (ListBag bs)	    = ListOfBags bs
+concatBag (ListOfBags bbs)  = ListOfBags (map concatBag bbs)
+
+partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
+					 Bag a {- Don't -})
+partitionBag _    EmptyBag = (EmptyBag, EmptyBag)
+partitionBag predic b@(UnitBag val) = if predic val then (b, EmptyBag) else (EmptyBag, b)
+partitionBag predic (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
+				  where
+				    (sat1,fail1) = partitionBag predic b1
+				    (sat2,fail2) = partitionBag predic b2
+partitionBag predic (ListBag vs)	  = (listToBag sats, listToBag fails)
+				  where
+				    (sats,fails) = partition predic vs
+partitionBag predic (ListOfBags bs) = (ListOfBags sats, ListOfBags fails)
+				  where
+				    (sats, fails) = unzip [partitionBag predic b | b <- bs]
+
+
+foldBag :: (r -> r -> r)	-- Replace TwoBags with this; should be associative
+	-> (a -> r)		-- Replace UnitBag with this
+	-> r			-- Replace EmptyBag with this
+	-> Bag a
+	-> r
+
+{- Standard definition
+foldBag t u e EmptyBag        = e
+foldBag t u e (UnitBag x)     = u x
+foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)
+foldBag t u e (ListBag xs)    = foldr (t.u) e xs
+foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs
+-}
+
+-- More tail-recursive definition, exploiting associativity of "t"
+foldBag _ _ e EmptyBag        = e
+foldBag t u e (UnitBag x)     = u x `t` e
+foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1
+foldBag t u e (ListBag xs)    = foldr (t.u) e xs
+foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs
+
+
+mapBag :: (a -> b) -> Bag a -> Bag b
+mapBag _ EmptyBag 	 = EmptyBag
+mapBag f (UnitBag x)     = UnitBag (f x)
+mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2) 
+mapBag f (ListBag xs)    = ListBag (map f xs)
+mapBag f (ListOfBags bs) = ListOfBags (map (mapBag f) bs)
+
+
+listToBag :: [a] -> Bag a
+listToBag [] = EmptyBag
+listToBag vs = ListBag vs
+
+bagToList :: Bag a -> [a]
+bagToList EmptyBag     = []
+bagToList (ListBag vs) = vs
+bagToList b = bagToList_append b []
+
+    -- (bagToList_append b xs) flattens b and puts xs on the end.
+    -- (not exported)
+bagToList_append :: Bag a -> [a] -> [a]
+bagToList_append EmptyBag 	 xs = xs
+bagToList_append (UnitBag x)	 xs = x:xs
+bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs)
+bagToList_append (ListBag xx)    xs = xx++xs
+bagToList_append (ListOfBags bs) xs = foldr bagToList_append xs bs
+\end{code}
+ src/BasicTypes.lhs view
@@ -0,0 +1,285 @@+%
+% @(#) $Docid: Feb. 9th 2003  16:35  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+\begin{code}
+module BasicTypes 
+
+	(
+	  Name
+
+	, QualName
+	, qName
+	, qOrigName
+	, qModule
+	, qDefModule
+	, mkQualName
+	, toQualName
+	, prefixQName
+	, prefixAppQName
+	, setOrigQName
+
+	, ScopedName
+	, Inherit
+	, GUID
+	, Size(..)
+	, CallConv(..)
+	, BinaryOp(..)
+	, UnaryOp(..)
+	, ShiftDir(..)
+	, Qualifier(..)
+	, PointerType(..)
+
+	, ParamDir(..)
+	, isInOut
+
+	, ppBinaryOp
+	, ppUnaryOp
+	, ppQualifier
+	, ppSize
+	, ppCallConv
+	, ppName
+	, ppQualName
+	, ppDirection
+	
+	, strToCallConv
+	
+	, EnumKind(..)
+	, classifyProgression
+
+	) where
+
+import PP
+import Maybe ( fromMaybe )
+import Opts  ( optNoQualNames, optIntIsInt )
+import Utils ( mapMb )
+import Int
+{- BEGIN_GHC_ONLY
+import GlaExts
+   END_GHC_ONLY -}
+\end{code}
+
+\begin{code}
+-- a generic.. name.
+type Name = String
+
+-- a qualified.. Name - used throughout the backend to keep
+-- track of home & name of types & values.
+data QualName = QName {
+		  qName       :: Name,
+		  qOrigName   :: Name,
+		  qModule     :: Maybe Name,
+		  qDefModule  :: Maybe Name  -- where the name was originally defined.
+		}
+	        deriving Eq
+
+mkQualName :: Maybe String -> String -> QualName
+mkQualName md nm = QName nm nm md Nothing
+
+toQualName :: String -> QualName
+toQualName str = 
+  case (break (=='.') (reverse str)) of
+    (_,[])    -> mkQualName Nothing str
+    (mn,_:dm) -> mkQualName (Just (reverse dm)) (reverse mn)
+
+setOrigQName :: Name -> QualName -> QualName
+setOrigQName nm qn = qn{qOrigName=nm}
+
+prefixQName :: String -> QualName -> QualName
+prefixQName v qn = qn{qName=v++qName qn , qDefModule=Nothing}
+
+prefixAppQName :: String -> QualName -> QualName
+prefixAppQName v qn = qn{qName=("(" ++v++" "++(qName qn)++")") , qDefModule=Nothing}
+
+-- scoped names is OMG CORBA, as it allows
+-- multi-level qualifiers on names, e.g., a::b::c
+type ScopedName = [String]
+
+-- an OMG interface can inherit from one or more interfaces.
+-- DCE/MS IDL: just the one (with COM, you get the effect of
+-- multiple inheritance from IUnknown.)
+type Inherit = [Name]
+
+-- A five element list
+type GUID = [String]
+
+data Size 
+ = Short | Natural | Long | LongLong
+   deriving (
+              Show -- for Lex debugging only
+	    , Eq
+	    ) 
+
+data CallConv = Stdcall | Pascal | Cdecl | Fastcall
+	        deriving ( Eq, Show )
+
+strToCallConv :: String -> Maybe CallConv
+strToCallConv "stdcall" = Just Stdcall
+strToCallConv "cdecl"   = Just Cdecl
+strToCallConv _		= Nothing
+\end{code}
+
+Arithmetic and logical operators allowed in IDL:
+
+\begin{code}
+data BinaryOp 
+ = Xor | Or  | And | Shift ShiftDir 
+ | Add | Sub | Div | Mod | Mul   
+ | LogAnd | LogOr
+ | Gt | Ge | Eq | Le | Lt | Ne
+ deriving ( Eq, Show ) 
+
+data UnaryOp  
+ = Minus | Plus | Not | Negate | Deref
+   deriving ( Eq, Show )
+
+data ShiftDir 
+ = L | R
+   deriving ( Eq, Show )
+
+data Qualifier 
+ = Const | Volatile
+   deriving (
+              Show
+	    , Eq
+	    )
+
+data PointerType 
+  = Ptr 
+  | Ref 
+  | Unique
+  deriving ( Eq, Show )
+
+data ParamDir   = In | Out | InOut
+                  deriving (Eq,Show) -- for Lex debugging only
+
+isInOut :: ParamDir -> Bool
+isInOut InOut = True
+isInOut _     = False
+
+\end{code}
+
+\begin{code}
+ppBinaryOp :: BinaryOp -> PPDoc a
+ppBinaryOp op =
+   case op of
+     Xor     -> char '^'
+     Or      -> char '|'
+     And     -> char '&'
+     Shift d -> text (case d of { L -> "<<" ; R -> ">>" })
+     Add     -> char '+'
+     Sub     -> char '-'
+     Div     -> char '/'
+     Mod     -> char '%'
+     Mul     -> char '*'
+     LogAnd  -> text "&&"
+     LogOr   -> text "||"
+     Gt      -> char '>'
+     Ge      -> text ">="
+     Eq      -> text "=="
+     Le      -> text "<="
+     Lt      -> char '<'
+     Ne      -> text "/="
+
+ppUnaryOp :: UnaryOp -> PPDoc a
+ppUnaryOp op =
+ case op of
+  Minus  -> char '-'
+  Plus   -> char '+'
+  Not    -> char '~'
+  Negate -> char '!'
+  Deref  -> char '*'
+
+ppQualifier :: Qualifier -> PPDoc a
+ppQualifier Const    = text "const"
+ppQualifier Volatile = text "volatile"
+\end{code}
+
+\begin{code}
+ppSize :: Size -> PPDoc a
+ppSize Short     = text "short"
+ppSize Long      = text "long"
+ppSize Natural 
+  | optIntIsInt  = text "int"
+  | otherwise    = text "long"
+ppSize LongLong  = text "long long"
+
+ppCallConv :: Bool -> CallConv -> PPDoc a
+ppCallConv for_c c =
+ text $
+ case c of 
+  Stdcall -> if for_c then "__stdcall" else "stdcall"
+   -- it is hard to find definite information on this, but I believe
+   -- that the Pascal calling convention is after all identical to
+   -- Stdcall. (The MSDN docs seems to be utterly confused as to whether
+   -- arguments are pushed L-to-R or R-to-L.)
+  Pascal  -> if for_c then "__stdcall" else "stdcall"
+--  Pascal  -> "pascal"
+   -- _cdecl is not provided with gcc, just omit.
+  Cdecl -> if for_c then "" else "ccall"
+--  Cdecl -> if for_c then "_cdecl" else "ccall"
+  Fastcall -> "fastcall"
+
+ppName :: Name -> PPDoc a
+ppName nm = text nm
+
+ppQualName :: QualName -> PPDoc a
+ppQualName (QName nm _ md def_mod)  
+ | optNoQualNames = text nm
+ | otherwise    =
+    case def_mod of
+      Nothing -> (fromMaybe empty (mapMb (\ m -> text m <> char '.') md)) <> text nm
+      Just m  -> text m <> char '.' <> text nm
+
+instance Show QualName where
+  showsPrec _ q = showString (showPPDoc (ppQualName q) ())
+
+\end{code}
+
+\begin{code}
+ppDirection :: ParamDir -> PPDoc a
+ppDirection d =
+ text $
+ case d of
+   In    -> "in"
+   Out   -> "out"
+   InOut -> "in, out"
+\end{code}
+
+A sequence of enumeration tags is classified according to
+what common class of progression it represent an instance of.
+Knowing this may help us generate less Haskell code in the end.
+(by using the "deriving" mechanism or, in the case of ghc, use
+its support for going straight between tag values and enum dtors.)
+
+\begin{code}
+data EnumKind
+ = EnumProgression
+       Int     -- start offset
+       Int     -- step. Note: *may* be < 0.
+ | EnumFlags      -- 0, 1, 2, 4, 8, ..
+       Int     -- start value
+ | Unclassified
+   deriving ( Show -- for debugging
+            , Eq
+	    )
+
+ -- assume that the tag sequence is appropriately sorted.
+ -- ('weird' int type of the tags is due to the fact that's
+ --  the one we're using in Core.)
+classifyProgression :: [Int32] -> EnumKind
+classifyProgression []  = Unclassified
+classifyProgression [x] = EnumProgression (fromIntegral x) 0
+classifyProgression ls@(x:y:_)
+  | x == y    			          = Unclassified
+  | and (zipWith (==) ls (pow2Series x))  = EnumFlags (fromIntegral x)
+  | and (zipWith (==) ls [x,(x+(y-x))..]) = EnumProgression (fromIntegral x) (fromIntegral (y-x))
+  | otherwise                             = Unclassified
+  where
+   pow2Series n = n : pow2Series (doub n)
+
+   doub n | n == 0    = 1
+   	  | otherwise = 2*n
+
+\end{code}
+ src/CStubGen.lhs view
@@ -0,0 +1,217 @@+%
+% (c) 1999, sof
+%
+
+Generate C stubs to make up the difference between the
+set of return types allowed by the GHC/Hugs FFI and C
+(C lets you return structs/unions by value, the FFI doesn't).
+
+\begin{code}
+module CStubGen (cStubGen) where
+
+import AbstractH
+import AbsHUtils ( splitFunTys )
+import PP
+import BasicTypes
+import Utils ( traceIf, dropSuffix )
+import Opts  ( optGenHeader, optVerbose, optOneModulePerInterface )
+import List  ( nub )
+import Maybe ( isJust )
+import Utils ( notNull )
+\end{code}
+
+\begin{code}
+cStubGen :: String       -- (base)name of output file
+	 -> [HTopDecl]   -- Haskell decls to derive C code from.
+	 -> String
+cStubGen c_nm hs = inc_header ((showPPDoc (hCode hs)) [])
+ where
+  inc_header ls =
+      -- avoid generating files containing just a singular #include.
+    case ls of
+      "" -> ls
+      _  | optGenHeader && not optOneModulePerInterface -> "#include "++ show (dropSuffix c_nm ++ ".h") ++ '\n':ls
+         | otherwise -> ls
+\end{code}
+
+The generated C code may contain bindings to DLLs that are linked
+by ordinal (Win32 specific), so we keep track of which DLLs they
+are and simply just inform the user that special steps needs to
+be taken in order to have this work successfully (i.e., need to
+get at the .a / .lib for that DLL or generate it from a .def file.)
+
+\begin{code}
+type CStubCode = PPDoc [String]
+
+getDllEnv :: ([String] -> CStubCode) -> CStubCode
+getDllEnv cont env = cont env env
+
+addToDllEnv :: String -> CStubCode -> CStubCode
+addToDllEnv nm cont env = cont (nm:env)
+
+hCode :: [HTopDecl] -> CStubCode
+hCode xs = whizz xs
+ where 
+  whizz [] = 
+    getDllEnv  $ \ dlls ->
+    let dlls_real = nub (filter notNull dlls) in
+    traceIf (optVerbose && notNull dlls_real)
+            ("\nStubs depend on entry points from the following DLLs/libraries:\n  " ++
+	     showList dlls_real (
+	     "\nyou may need to adjust your command-line when compiling the stubs to" ++
+	     "\ntake this into account.")) empty
+  whizz (HLit _ : ls)     = whizz ls
+  whizz (CLit s : ls)
+    | not optGenHeader    = text s $$ whizz ls
+    | otherwise           = whizz ls
+  whizz (HInclude s : ls) = text "#include" <+> text (escapeString s) $$
+  			    whizz ls
+  whizz (HMod hm : ls)    = hMod hm (whizz ls)
+
+  escapeString s@('"':_) = s -- "
+  escapeString s@('<':_) = s
+  escapeString s         = show s
+
+hMod :: HModule -> CStubCode -> CStubCode
+hMod (HModule _ _ _ _ d) cont = hDecl d cont
+
+hDecl :: HDecl -> CStubCode -> CStubCode
+hDecl (AndDecl d1 d2) cont = hDecl d1 (hDecl d2 cont)
+hDecl (Primitive _ cc lspec nm ty needs_wrapper c_args c_res) cont
+ | not needs_a_wrapper = cont
+ | otherwise	       =
+   addToDllEnv dll_name $
+   tdefFun lspec cc c_args c_res $$
+   primHeader nm c_res c_args    $$ 
+   lbrace $$
+     declResult $$
+     performCall False lspec ty c_args $$
+     pushResult c_res ty $$
+   rbrace $$
+   cont
+ where
+  declResult = 
+    case snd c_res of
+      "void" -> empty
+      x      -> text x <+> text "res" <> semi
+
+  needs_a_wrapper = needs_wrapper || isJust mb_ord
+
+  (dll_name, mb_ord, _, _) = lspec
+
+  tdefFun (_,Nothing,_,_) _ _ _ = empty
+  tdefFun (_,Just _,tnm,_) tcc args res = 
+    text "extern" <+> text (snd res) <+> ppCallConv True tcc <+> text tnm <+>
+    ppTuple (map (text.snd) args) <> semi
+
+hDecl (PrimCast cc nm ty needs_wrapper c_args c_res) cont
+ | not needs_wrapper = cont
+ | otherwise	     = 
+   tdefFunTy ty nm cc c_args c_res $$
+   primHeader nm c_res c_args      $$ 
+   lbrace $$
+     declResult $$
+     text (nm++"__funptr __funptr__;") $$
+     text ("__funptr__ = ("++nm++"__funptr)arg0;") $$
+     performCall True ("", Nothing, "__funptr__", Nothing) ty c_args $$
+     pushResult c_res ty $$
+   rbrace $$
+   cont
+ where
+  declResult = 
+    case snd c_res of
+      "void" -> empty
+      x      -> text x <+> text "res" <> semi
+
+hDecl (Include s) cont = text ("#include " ++ s) $$ cont
+hDecl (CCode s)   cont
+  | not optGenHeader   = text s $$ cont
+  | otherwise          = cont
+hDecl _ cont = cont
+\end{code}
+
+\begin{code}
+primHeader :: Name -> (Bool,String) -> [(Bool,String)] -> CStubCode
+primHeader nm res args = 
+  text the_res <+> text nm <+> 
+  ppTuple (zipWith (\ x n -> text (showTy x) <+> ppArg n) args [(0::Int)..])
+ where
+  the_res = showTy res
+
+showTy :: (Bool,String) -> String
+showTy (is_str,ty_str)
+ | is_str    = ty_str ++ "*"
+ | otherwise = ty_str
+
+ppArg :: Int -> CStubCode
+ppArg n = text ("arg"++show n)
+
+\end{code}
+
+\begin{code}
+performCall :: Bool -> LocSpec -> Type -> [(Bool,String)] -> CStubCode
+performCall is_dyn (_, _, fun, _) ty c_args = 
+   ppAssign res <> text fun <> ppTuple fun_args <> semi
+ where
+  (_, res) = splitFunTys ty
+
+  fun_args
+    | is_dyn    = tail funArgs
+    | otherwise = funArgs
+
+  funArgs = zipWith funArg [0..] c_args
+
+  funArg n (is_struct, _)
+     | is_struct  = char '*' <> ppArg n
+     | otherwise  = ppArg n
+
+  ppAssign t
+    | noResultTy t = empty 
+    | otherwise    = text "res" <+> equals
+
+\end{code}
+
+\begin{code}
+pushResult :: (Bool, String) -> Type -> CStubCode
+pushResult (isStructTy, c_ty) ty = assignRes 
+ where 
+  (_, res) = splitFunTys ty
+
+  noResult = noResultTy res
+  
+  assignRes
+    | noResult  = empty
+    | otherwise = text "return" <+> parens (the_result) <> semi
+
+  the_result
+   | isStructTy = text "copyBytes" <> parens (
+			text "sizeof" <> parens (text c_ty) <>
+			text ", &res")
+   | otherwise  = text "res"
+
+\end{code}
+
+\begin{code}
+tdefFunTy :: Type -> Name -> CallConv -> [(Bool,String)] -> (Bool,String) -> CStubCode
+tdefFunTy ty nm cc c_args (_,c_res) =
+ text "typedef" <+> ppResultTy <+>
+   parens ( ppCallConv True cc <+> char '*' <+> 
+	    text (nm++"__funptr")) <+>
+   ppTuple ppArgs <> semi
+ where
+  (_, res) = splitFunTys ty
+
+  ppResultTy
+   | noResult  = text "void"
+   | otherwise = text c_res
+
+  ppArgs = zipWith pp_arg [1..] (tail c_args)
+  
+  pp_arg n (_,t) = text t <+> ppArg n
+
+  noResult = noResultTy res
+
+noResultTy :: Type -> Bool
+noResultTy (TyApply (TyCon _) [TyCon tc]) = qName tc == "()"
+noResultTy _				  = False
+\end{code}
+ src/CgMonad.lhs view
@@ -0,0 +1,298 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 9th 2003  14:49  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+The code generator carries around information about
+the abstract Haskell code that's being generated:
+
+    - the export list so far.
+    - the context we're in (e.g., are we processing
+      a COM method)
+    - etc.
+
+\begin{code}
+module CgMonad 
+	(
+	  CgM
+        , IfaceType(..)
+	, runCgM
+
+	, getDllName		-- :: CgM String
+	, setDllName		-- :: String -> CgM a -> CgM a
+
+	   -- decl name is the name of the IDL unit (i.e.,
+	   -- module/interface etc.) being translated.
+	   --
+	, getDeclName		-- :: (String -> CgM a) -> CgM a
+	, withDeclName	        -- :: String -> CgM a -> CgM a
+	, withIfaceDeclName     -- :: String -> CgM a -> CgM a
+	
+	, needStubs		-- :: Bool -> CgM ()
+	, hasPrims		-- :: CgM ()
+
+	, setInterfaceFlag      -- :: IfaceType -> CgM a -> CgM a
+	, getInterfaceFlag	-- :: CgM IfaceType
+
+	, setSourceIfaceFlag    -- :: Bool -> CgM a -> CgM a
+	, getSourceIfaceFlag	-- :: CgM Bool
+
+	, setClientFlag         -- :: Bool -> CgM a -> CgM a
+	, getClientFlag	        -- :: CgM Bool
+
+	, getIfaceName		-- :: CgM String
+	, setIfaceName		-- :: String -> CgM a -> CgM a
+	
+	, inDispInterface       -- :: CgM a -> CgM a
+	, isInDispInterface     -- :: CgM Bool
+	
+	, setIfaceAttributes    -- :: [Attribute] -> CgM a -> CgM a
+	, getIfaceAttributes    -- :: CgM [Attribute]
+	
+	, getIfaceInherit	-- :: CgM [QualName]
+	, withIfaceInherit	-- :: [QualNam] -> CgM a -> CgM a
+	
+        , IsoEnv
+	, getIsoEnv		-- :: CgM IsoEnv
+	, setIsoEnv		-- :: IsoEnv -> CgM ()
+	
+	, getIEnumFlag		-- :: CgM Bool
+	, setIEnumFlag		-- :: Bool -> CgM a -> CgM a
+	
+	, addDynStub            -- :: String -> String -> CgM ()
+	, lookupDynStub 	-- :: String -> Maybe String
+
+	, addExport		-- :: HIEEntity -> CgM ()
+	, addVitalExport	-- :: HIEEntity -> CgM ()
+	, addExportWithComment  -- :: HIEEntity -> String -> CgM ()
+	, exportDecl		-- :: (String, HDecl) -> CgM HDecl
+
+	, addExplicitImports    -- :: [(Bool,String)] -> CgM ()
+	
+	, hoistInClass		-- :: String -> (String -> CgM a) -> CgM a
+	
+	, getMethodNumber	-- :: Maybe Int -> CgM Int
+	, setMethodNumber	-- :: Int -> CgM ()
+	, incMethodNumber	-- :: CgM ()
+
+	) where
+
+import Env
+import AbstractH
+import CoreIDL    ( Result, Param, Id, Attribute )
+import Opts	  ( optServer, optOneModulePerInterface )
+import Maybe	  ( fromMaybe )
+import BasicTypes ( QualName )
+
+\end{code}
+
+Information is carried both down and along:
+
+\begin{code}
+newtype CgM a = CgM ( CgDown -> CgState -> (a, CgState) )
+
+data CgDown 
+ = CgDown {
+      if_ty     :: IfaceType,
+      if_client :: Bool,   -- True => generating client stubs.
+      if_source :: Bool,   -- True => processing outgoing interface
+      if_ienum  :: Bool,   -- True => processing IEnum interface
+      if_disp   :: Bool,
+      dll_nm    :: String,
+      mod_nm    :: String,
+      if_nm     :: String,
+      if_attrs  :: [Attribute],
+      if_inh    :: [QualName],
+      iface_env :: Env String (Maybe Id)
+   }
+
+data IfaceType
+ = StdFFI
+ | VTBLObject         -- client
+ | ComIDispatch Bool  -- client, True => [dual]
+   deriving Eq
+
+type IsoEnv = Env String [(Bool, Result, [Param])]
+
+data CgState = 
+   CgState {
+     exp_list   :: [(HIEEntity, Bool, Maybe String)],  -- export list
+     imp_list   :: [(String,Bool,[HIEEntity])],
+     dyn_env    :: Env String{-'signature' string of a type-} (Bool, String),
+     iso_env    :: IsoEnv,
+     meth_no    :: !Int,
+     need_stubs :: Bool,
+     has_prims  :: Bool
+   }
+
+runCgM :: Env String [(Result, [Param])]
+       -> Env String (Maybe Id)
+       -> CgM a
+       -> ( a
+          , [(HIEEntity, Bool, Maybe String)]
+          , [(String, Bool, [HIEEntity])]
+	  , Bool
+	  , Bool
+	  )
+runCgM isoEnv ifaceEnv (CgM act) = 
+  case (act (CgDown iface_flg is_client is_source is_ienum 
+  		    is_disp "" "" "" [] [] ifaceEnv)
+            (CgState [] [] newEnv iso_env' 0 False False)) of
+    (v,CgState expo imps _ _ _ flg1 flg2) -> (v, reverse expo, imps, flg1, flg2)
+ where
+  is_client     = not optServer
+  is_ienum      = False
+  is_source     = False
+  is_disp       = False
+  iface_flg     = StdFFI
+
+  iso_env' = mapEnv (\ _ ls -> map (\ (as,bs) -> (True, as, bs)) ls) isoEnv
+
+getDllName :: CgM String
+getDllName = CgM (\ env st -> (dll_nm env, st))
+
+setDllName :: String -> CgM a -> CgM a
+setDllName dname (CgM a) = CgM (\ env st -> a (env{dll_nm=dname}) st)
+
+getDeclName :: (String -> CgM a) -> CgM a
+getDeclName cont = CgM (\ env st -> let (CgM a) = cont (mod_nm env) in a env st)
+
+needStubs :: Bool -> CgM ()
+needStubs flg = CgM (\ _ st -> ((), st{need_stubs=need_stubs st || flg}))
+
+hasPrims :: CgM ()
+hasPrims = CgM (\ _ st -> ((), st{has_prims=True}))
+
+withDeclName :: String -> CgM a -> CgM a
+withDeclName mname (CgM a) = CgM (\ env st -> a (env{mod_nm=mname}) st)
+
+withIfaceDeclName :: String -> CgM a -> CgM a
+withIfaceDeclName mname act
+  | not optOneModulePerInterface = act
+  | otherwise                    = withDeclName mname act
+
+setInterfaceFlag :: IfaceType -> CgM a -> CgM a
+setInterfaceFlag flg (CgM a) = CgM (\ env st -> a (env{if_ty=flg}) st)
+
+setClientFlag :: Bool -> CgM a -> CgM a
+setClientFlag flg (CgM a) = CgM (\ env st -> a (env{if_client=flg}) st)
+
+getClientFlag :: CgM Bool
+getClientFlag = CgM (\ env st -> (if_client env, st))
+
+getInterfaceFlag :: CgM IfaceType
+getInterfaceFlag = CgM (\ env st -> (if_ty env, st))
+
+getIfaceName :: CgM String
+getIfaceName = CgM (\ env st -> (if_nm env, st))
+
+getIfaceAttributes :: CgM [Attribute]
+getIfaceAttributes = CgM (\ env st -> (if_attrs env, st))
+
+getIfaceInherit :: CgM [QualName]
+getIfaceInherit = CgM (\ env st -> (if_inh env, st))
+
+withIfaceInherit :: [QualName] -> CgM a -> CgM a
+withIfaceInherit ls (CgM a) =
+  CgM (\ env st -> a (env{if_inh=ls}) st)
+
+setIfaceName :: String -> CgM a -> CgM a  
+setIfaceName iface (CgM a) =
+  CgM (\ env st -> a (env{if_nm=iface}) st)
+
+setIfaceAttributes :: [Attribute] -> CgM a -> CgM a  
+setIfaceAttributes as (CgM a) = CgM (\ env st -> a (env{if_attrs=as}) st)
+
+getIsoEnv :: CgM IsoEnv
+getIsoEnv = CgM (\ _ st -> (iso_env st, st))
+
+setIsoEnv :: IsoEnv -> CgM ()
+setIsoEnv env = CgM (\ _ st -> ((),st{iso_env=env}))
+
+getIEnumFlag :: CgM Bool
+getIEnumFlag = CgM (\ env st -> (if_ienum env, st))
+
+setIEnumFlag :: Bool -> CgM a -> CgM a
+setIEnumFlag i (CgM a) = CgM (\ env st -> a (env{if_ienum=i}) st)
+
+getSourceIfaceFlag :: CgM Bool
+getSourceIfaceFlag = CgM (\ env st -> (if_source env, st))
+
+setSourceIfaceFlag :: Bool -> CgM a -> CgM a
+setSourceIfaceFlag i (CgM a) = CgM (\ env st -> a (env{if_source=i}) st)
+
+addExport :: HIEEntity -> CgM ()
+addExport nm = CgM ( \ _ st -> ((), st{exp_list=(nm, False, Nothing):exp_list st}))
+
+addVitalExport :: HIEEntity -> CgM ()
+addVitalExport nm = CgM ( \ _ st -> ((), st{exp_list=(nm, True, Nothing):exp_list st}))
+
+hoistInClass :: String -> (Maybe Id -> CgM a) -> CgM a 
+hoistInClass nm cont =  
+  CgM (\ env st -> 
+         let 
+	   (CgM a) = cont (fromMaybe Nothing (lookupEnv (iface_env env) nm))
+	 in
+	 a env st)
+
+addExportWithComment :: HIEEntity -> String -> CgM ()
+addExportWithComment nm comm =
+ CgM ( \ _ st -> ((), st{exp_list=(nm, False, Just comm):exp_list st}))
+
+addExplicitImports :: [(Bool,String)] -> CgM ()
+addExplicitImports imps = CgM ( \ _ st -> ((), st{imp_list= map (\ (x,y) -> (y,x,[])) imps ++imp_list st}))
+
+exportDecl :: (String, HDecl) -> CgM HDecl
+exportDecl (nm,d) = do
+   addExport (IEVal nm)
+   return d
+
+-- 'convenient' interface that combines the result of
+-- looking up whether 
+getMethodNumber :: Maybe Int -> CgM Int
+getMethodNumber (Just i) = return i
+getMethodNumber Nothing  = CgM (\ _ st -> (meth_no st, st))
+
+incMethodNumber :: CgM ()
+incMethodNumber = CgM (\ _ st -> ((), st{meth_no=1+meth_no st}))
+
+setMethodNumber :: Int -> CgM ()
+setMethodNumber n = CgM (\ _ st -> ((), st{meth_no=n}))
+\end{code}
+
+\begin{code}
+inDispInterface :: CgM a -> CgM a
+inDispInterface (CgM a) = CgM (\ env st -> a (env{if_disp=True}) st)
+
+isInDispInterface :: CgM Bool
+isInDispInterface = CgM (\ env st -> (if_disp env, st))
+
+\end{code}
+
+Within a Haskell module we share 'foreign export dynamic'
+(or equivalent) stubs, if possible.
+
+\begin{code}
+addDynStub :: String -> String -> Bool -> CgM ()
+addDynStub nm sig is_exp = CgM $ \ _ st ->
+   ((),st{dyn_env=addToEnv (dyn_env st) sig (is_exp,nm)})
+
+lookupDynStub :: String -> CgM (Maybe (Bool, String))
+lookupDynStub sig = CgM $ \ _ st ->
+   (lookupEnv (dyn_env st) sig, st)
+
+\end{code}
+
+
+\begin{code}
+instance Monad CgM where
+  (>>=) (CgM a) f = 
+    CgM (\ env st -> 
+  	   case a env st of
+	     (v, st1) -> let CgM b = f v in b env st1)
+  return v = CgM (\ _ st -> (v, st))
+
+\end{code}
+
+ src/CodeGen.lhs view
@@ -0,0 +1,1234 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Mar. 31th 2003  08:52  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Toplevel module for converting IDL into abstract Haskell code,
+ready for dumping out to a file.
+
+\begin{code}
+module CodeGen ( codeGen ) where
+
+import MarshallUtils
+import MarshallStruct
+import MarshallEnum
+import MarshallType
+import MarshallMethod
+import MarshallUnion
+import MarshallAbstract  ( marshallAbstract )
+import MarshallServ
+import MarshallCore
+import MarshallFun
+import MarshallJNI
+import MarshallJServ
+import Skeleton
+import qualified CustomAttributes
+
+import BasicTypes
+import Literal
+import AbstractH hiding (Type(..), Expr(..),CaseAlt(..))
+import qualified AbstractH as Haskell ( HDecl(..),
+					TyDecl(..),
+					ConDecl(..),
+					BangType(..)
+				      )
+import AbsHUtils
+import MkImport      ( mkImportLists )
+import LibUtils
+import Opts ( optGenHeader, optNoExportList,
+	      optOneModulePerInterface, optServer,
+	      optUnparamedInterfacePointers,
+	      optSubtypedInterfacePointers, optExportAbstractly,
+	      optDualVtbl, optDon'tGenBinaryComInterfaces,
+	      optSkel, optIgnoreDispInterfaces, optNoLibIds,
+	      optIgnoreSourceIfaces, optNoEnumMagic, optHaskellToC,
+	      optJNI, optCorba, optIgnoreMethsUpto, optUseStdDispatch,
+	      optOutputHTo, optEnumsAsFlags, optGenNumInstance, optGenBitsInstance
+	    )
+import PpAbstractH ( ppType, showAbstractH )
+import PpCore ( showCore, ppDecl )
+import CgMonad
+
+import CoreIDL
+import CoreUtils
+import Attribute
+import List  ( partition, intersperse, isPrefixOf )
+import Utils ( dropSuffix, trace, basename, split,
+	       splitdir, prefixDir, notNull
+	     )
+import Maybe ( mapMaybe, isJust )
+import Monad ( when )
+
+import Env
+\end{code}
+
+External interface, convert a set of toplevel IDL
+declarations into their Haskell form.
+
+A translation unit can at the toplevel consist of:
+
+ - one or more modules
+ - one or more libraries
+ - one or more (disp)interfaces/coclasses.
+
+IDL grouping declarations map onto Haskell modules as follows:
+ 
+ - modules and libraries get their own Haskell module.
+ - optionally, each (disp)interface/coclass can be put into
+   a file of their own. (doing this eases the problem of
+   namespace clashes, relying instead on the Haskell module
+   system to operate satisfactorily..)
+
+\begin{code}
+codeGen :: (Either String String, Maybe String)
+               {- User-supplied output name -}
+	-> Env String [(Result, [Param])]
+	       {- environment carrying type isomorphic methods info -}
+	-> Env String (Maybe Id)
+	       {- environment containing ifaces that should be ignored -}
+        -> [Decl]
+	-> ( [(String, Decl)]		        {- possible header file output  -}
+	   , [(String, Bool, [HTopDecl])]       {- Haskell output		-}
+	   )
+codeGen (o_fname, mname) iso_env iface_env decls =
+  ( generateHeader top_module_name decls
+  , (\ x -> if optSkel then x ++ cgSkeleton decls else x) $
+    liftOut (map (cGen iso_env iface_env) modules)
+  )
+ where
+  liftOut [] = []
+  liftOut (m@(nm, has_struct, ds) : ms) =
+     case break isHMod ds of
+       (ls,[x,HMod md@(HModule nm1 _ _ _ _)]) -> 
+		    (nm, has_struct, ls ++ [x]) : 
+		    (nm1 ++ ".hs", False, [HMod md]) : liftOut ms
+       _ -> m : liftOut ms
+
+  isHMod (HMod _) = True
+  isHMod _	  = False
+
+   -- The set of modules to generate. If there's any leftovers at the
+   -- top (i.e., stuff that appear outside a module/library/interface etc. grouping),
+   -- we put these bits into the top_module. In the one-module-per-interface 
+   -- case, this means that for typedefs that appear inside interfaces will
+   -- be lifted out and be generated with the outermost module (arguably they
+   -- shouldn't be lifted out, but that's how things are organised at the moment.)
+  modules = 
+   case mods_and_libs of
+     [_] -> [one_module] -- make sure we emit everything.
+     _   ->
+      case rest of
+        [] -> mods_and_libs
+        _  -> top_module : mods_and_libs
+
+  toStdOut = 
+    case o_fname of
+      Right "-" -> True
+      _		-> False
+
+  -- use output filename to generate a plausible looking
+  -- Haskell module name.
+  (top_module_name, output_fname) = 
+     case mname of
+       Just x -> (x, snd ofnames)
+       _      -> ofnames
+    where
+     ofnames =
+         case o_fname of
+          Right "-" -> 
+	  	case mods_and_libs of 
+		   ((_,m,_):_) -> (m, "-")
+		   _	       -> ("Anon", "-")
+	  Left  x   -> let 
+	  		(_,base) = splitdir x
+			y = mkHaskellTyConName (dropSuffix base)
+		       in
+		       (y, x)
+	  Right x   ->
+	    case mods_and_libs of
+	      [(_,m,_)] -> let
+	                    (dir,_) = splitdir x 
+	      		   in (m, prefixDir dir (m ++ ".hs"))
+
+	      _	        -> (mkModName x, x)
+
+     mkModName x  = mkHaskellTyConName (basename (dropSuffix x))
+
+  top_module = ( output_fname
+	       , top_module_name
+	       , mkTopModule (mkId top_module_name
+	       			   top_module_name
+				   Nothing
+				   [{-no attrs-}])
+				   rest
+	       )
+
+  one_module = ( output_fname
+	       , top_module_name
+	       , mkTopModule (mkId top_module_name
+	       			   top_module_name
+				   Nothing
+				   [{-no attrs-}])
+				   flattened_decls
+	       )
+
+   -- Hoist out some of these. Currently they all have to be at the top,
+   -- we don't scan through the whole file looking for them.
+  mkTopModule i (d@(HsLiteral _) : xs) = d : mkTopModule i xs
+  mkTopModule i (d@(CInclude _) : xs)  = d : mkTopModule i xs
+  mkTopModule i (d@(CLiteral _) : xs)  = d : mkTopModule i xs
+   -- delayed addition of the attributes for the module itself.
+  mkTopModule i ds@(d@Module{} : _)    = [Module i{idAttributes=idAttributes (declId d)} ds]
+  mkTopModule i ds@(d@Library{} : _)   = [Module i{idAttributes=idAttributes (declId d)} ds]
+  mkTopModule i ds		       = [Module i ds]
+
+  mods_and_libs = map ( \ d -> let (x,y) = mkModuleLibName d in (x, y, [d])) mods_and_libs'
+  (mods_and_libs', rest) = partition inSeparateHaskellModule flattened_decls
+
+  flattened_decls = flattenDecls decls
+
+  mkModuleLibName d 
+    | toStdOut  = ("-", hnm)
+    | otherwise = (hnm ++ ".hs", hnm)
+      where
+	   hnm = mkHaskellTyConName nm
+	   nm_raw = idName (declId d)
+	   nm
+	    | optServer = nm_raw ++ "Proxy"
+	    | otherwise = nm_raw
+\end{code}
+
+\begin{code}
+cGen :: Env String [(Result, [Param])]
+     -> Env String (Maybe Id)
+     -> (String, String, [Decl]) 
+     -> (String, Bool, [HTopDecl])
+cGen iso_env iface_env (oname, mod_name, ds) = (oname, flg, ds')
+ where
+  (ds',flg) = foldr mkHTop ([],False) ds
+
+  mkHTop d (acc, has_structs) = 
+   case d of
+     Library i ms ->
+       case (runCgM iso_env iface_env (withDeclName (idName i) (cgLibrary i ms))) of
+        (decl, expo, imps, flg1, has_prim) -> 
+	  let qual_imps = mkImportLists mod_name (getHsImports i) [decl]
+	      real_imps = qual_imps ++ imps
+
+	  in
+	  (modDecl i has_prim [decl] real_imps expo : acc, has_structs || flg1)
+     DispInterface i _ _ _ ->
+       case (runCgM iso_env iface_env (withIfaceDeclName (idName i) (cgDecl d))) of
+         (decl, expo, imps, flg1, has_prim) -> 
+	   let qual_imps = mkImportLists mod_name (getHsImports i) [decl] 
+	       real_imps = qual_imps ++ imps
+	   in
+	   (modDecl i has_prim [decl] real_imps expo : acc, has_structs || flg1)
+     Interface i is_ref inherit _
+       | not is_ref ->
+         case (runCgM iso_env iface_env (withIfaceDeclName (idName i) (cgDecl d))) of
+           (decl, expo, imps, flg1, has_prim) -> 
+	     let qual_imps = mkImportLists mod_name (getHsImports i) [decl] 
+	         real_imps = qual_imps ++ imps
+
+		 attrs	    = idAttributes i
+		 iface_deps = filterAttributes attrs ["depender"]
+		 new_attrs  = filterOutAttributes attrs ["depender"]
+		 i'	    = i{idAttributes=new_attrs}
+		 (acc', has_structs')
+		    | not optOneModulePerInterface || null iface_deps = (acc, has_structs)
+		    | otherwise	 = 
+			case mkHTop (Interface i' False inherit []) (acc, has_structs) of
+			  (HMod (HModule nm a b c d1) : ls, e) ->
+			     (HMod (HModule (nm ++ "Ty") a b c d1) : ls , e)
+			  x -> x
+	     in
+	     (modDecl i has_prim [decl] real_imps expo : acc', has_structs' || flg1)
+       | otherwise -> (acc, has_structs)
+     CoClass{} -> 
+       case (runCgM iso_env iface_env (cgDecl d)) of
+         (decl, expo, imps, flg1, has_prim) -> 
+	   let qual_imps = mkImportLists mod_name (getHsImports (declId d)) [decl]
+	       real_imps = qual_imps ++ imps
+
+	   in
+	   if isEmptyDecl decl then
+	       (acc, has_structs)
+	   else
+   	       (hModule mod_name
+		        has_prim
+  		        (map (\ (x,_,y) -> hExport x y) expo)
+  		        (map (\ (x,y,z) -> hImport x y z) real_imps)
+ 		        decl : acc, has_structs || flg1)
+     Module i ms -> 
+       case (runCgM iso_env iface_env (withDeclName (idName i) (cgModule i ms))) of
+         (decl, expo,imps,flg1, has_prim) -> 
+	    let qual_imps = mkImportLists mod_name (getHsImports i) [decl]
+	        real_imps = qual_imps ++ imps
+	    in
+	    ( modDecl (i{idName=mod_name}) has_prim [decl] real_imps expo : acc
+	    , has_structs || flg1
+	    )
+     HsLiteral s -> (hMeta s    : acc, has_structs)
+     CLiteral s  -> (cMeta s    : acc, has_structs)
+     CInclude s  -> (hInclude s : acc, has_structs)
+     _		 -> error ("Odd decl: " ++ showCore (ppDecl d))
+
+  modDecl _ mflg decls imps expo
+    | optNoExportList =
+        hModule mod_name mflg
+                (map (\ (x,_,y) -> hExport x y) $ filter (\ (_,x,_) -> x) expo)
+                (map (\ (x,y,z) -> hImport x y z) imps)
+                (andDecls decls)
+    | otherwise =
+      hModule mod_name mflg
+	      (map (\ (x,_,y) -> hExport x y) expo)
+	      (map (\ (x,y,z) -> hImport x y z) imps)
+	      (andDecls decls)
+\end{code}
+
+From the .idl input, we optionally generate C header file information. This is
+useful when the master copy of the .h file is the .idl specification (or, you
+don't have the header file already available.)
+
+\begin{code}
+generateHeader :: String -> [Decl] -> [(String, Decl)]
+generateHeader o_fname decls
+ | not optGenHeader = []
+ | otherwise	    = 
+    case optOutputHTo of
+      (x:_) -> 
+         let
+	  nm = dropSuffix x
+	 in
+	 [(oname, Module (mkId nm nm Nothing []) decls)]
+      _ -> 
+       case (concatMap mkHeaderDecls decls) of
+        []      -> [(oname, Module (mkId oname oname Nothing []) decls)]
+        [(_,s)] -> [(oname, s)]
+        ls	-> ls
+ where
+  oname = 
+    case optOutputHTo of
+      (x:_) -> x
+      _ ->
+       case o_fname of
+          "-" -> "-"
+          _   -> dropSuffix o_fname ++ ".h"
+
+  mkHeaderNm i = mkHaskellTyConName (idName i) ++ ".h"
+
+  mkHeaderDecls d =
+    case d of
+      Module	i _	    -> [(mkHeaderNm i, d)]
+      Interface i _ _ _     -> [(mkHeaderNm i, d)]
+      DispInterface i _ _ _ -> [(mkHeaderNm i, d)]
+      Library i _	    -> [(mkHeaderNm i, d)]
+      _			    -> []
+
+\end{code}
+
+Generating code for the various Core IDL declarations:
+
+\begin{code}
+
+cgDecl :: Decl -> CgM HDecl
+cgDecl d =
+ case d of
+   Typedef n t _	            -> cgTypedef n t
+   Constant i t o_t e	            -> cgConstant i t o_t e
+   Interface i _ inherit decls -> 
+     withIfaceInherit (map fst inherit) $ 
+     hoistInClass (idName i)		$ \ mb_cls -> do
+     cls_d <-
+         {-
+	   Check to see if we should include a CLSID declaration
+	   as well. Do this in the case where we've got
+	     
+ 	     interface _A { ... }; coclass A { interface _A; };
+           
+           and A has the only use of _A. Useful in one-module-per-interface mode,
+	   as it avoids creating a (v simple) module for the coclass.
+	 -}
+       case mb_cls of
+         Nothing -> return emptyDecl
+	 Just ci
+	    | notNull deps -> return emptyDecl
+	    | otherwise	   -> do
+	   let ci'
+	        | idName i `isPrefixOf` idName ci = ci{idName=idName i}
+		| otherwise			  = ci
+
+           ud <- setInterfaceFlag (ComIDispatch False) (uuidDecl ci' [] Clsid)
+           return (infoHeader (CoClass ci' [CoClassInterface i Nothing]) `andDecl` ud)
+
+     forClient <- getClientFlag
+     let is_source = hasSourceAttribute (idAttributes i)
+     setSourceIfaceFlag is_source $ do
+      dserv <- 
+        if (is_source && optIgnoreSourceIfaces) then
+           return emptyDecl
+        else 
+          if (is_source && forClient) || (not forClient && not is_source) then
+              marshallServ i inherit decls
+           else
+             cgInterface i inherit decls
+      return (cls_d `andDecl` dserv) 
+    where
+      deps = filterAttributes (idAttributes i) ["depender"]
+
+   Method i cc res ps offs     -> do
+     forClient <- getClientFlag
+     is_source <- getSourceIfaceFlag
+     if (is_source && forClient) || (not forClient && not is_source) then do
+        k <- getInterfaceFlag
+        case k of
+	  StdFFI -> getDeclName $ \ nm ->
+		    marshallFun (Just nm) i (FunTy cc res ps) 
+          _ | optJNI    ->  cgJServMethod i res ps
+	    | otherwise ->  do
+	        isInDisp <- isInDispInterface
+	    	cgServMethod i res ps is_source (optUseStdDispatch && isInDisp)
+      else
+	if optJNI then
+	   cgJNIMethod i res ps
+	 else
+  	   cgMethod i cc res ps offs Nothing
+
+   Property i ty _ s g      -> cgProperty i ty s g
+   HsLiteral str	    -> return (Haskell str)
+   CLiteral str             -> return (CCode str)
+   CInclude  fname          -> return (Include fname)
+   DispInterface i ii ps ms -> cgDispInterface i ii ps ms
+   CoClass i mems	    -> cgCoClass i mems
+   Library i decls	    -> cgLibrary i decls
+   Module i ds		    -> cgModule i ds
+   _			    -> return emptyDecl
+
+\end{code}
+
+
+%
+%
+<sect2>Typedefs
+<label id="sec:typedef">
+<p>
+%
+%
+
+An IDL typedef have the following form:
+
+  typedef type name;
+
+The translation into a Haskell type declaration is
+implemented as follows:
+
+<verb>
+ D[typedef type name] = "DT[type] Con[name] = T[type]"
+</verb>
+
+where <tt/Con[]/ is the mapping from an IDL name to a
+Haskell type constructor name and <tt/DT[]/ uses the IDL
+type to determine what kind of Haskell user-defined data
+type declaration to use. 
+
+The meat of the translation is done by the <tt/T[]/ mapping
+scheme, which is implemented by <tt/toHaskellTy/ in @MarshallType@.
+
+\begin{code}
+cgTypedef :: Id -> Type -> CgM HDecl
+cgTypedef tdef_id ty
+  | (idAttributes tdef_id) `hasAttributeWithName` CustomAttributes.ignoreAttr
+  = return emptyDecl
+  | otherwise = do
+    addExport (ieType hname (is_tysyn || optExportAbstractly))
+    d <- cgMarshallTy tdef_id ty
+    return (typedef `andDecl` d)
+  where
+    attrs = idAttributes tdef_id
+    hname = mkHaskellTyConName (idName tdef_id)
+    
+    isNewType = attrs `hasAttributeWithName` CustomAttributes.newtypeAttr
+    isPure    = attrs `hasAttributeWithName` CustomAttributes.pureAttr
+
+     -- the support for represent_as() is currently
+     -- restricted to types in typedefs (i.e., no
+     -- support for hooking in your own marshallers.)
+    (the_ty, tvs) =
+      case findAttribute "represent_as" attrs of
+         Just (Attribute _ (ParamLit (StringLit s):_)) -> (tyConst s, [])
+	 _ -> 
+	  case (unconstrainType (groundTyVars (toHaskellTy True ty))) of
+	     (ls,t) -> (purify t, map (qName.snd) ls)
+
+    purify ty1
+      | isPure     = purifyType ty1
+      | otherwise  = ty1
+
+     -- the DT[] translation. IDL simple types, arrays and pointers
+     -- are mapped onto type synonyms, the rest are algebraic data types.
+ 
+    is_tysyn = 
+         isSimpleTy ty
+      || isAbstractTy ty
+      || isBoolTy ty
+      || isArrayTy ty
+      || isSafeArrayTy ty
+      || isPointerTy ty
+      || isSynTy ty
+      || isFunTy ty
+      || isIntegerTy ty
+      || isStringTy ty  
+      || isSeqTy ty
+    typedef
+      | isNewType && null (tail conDecls) = dataType
+      | is_tysyn  = tySyn hname tvs the_ty
+      | otherwise = dataType
+
+    conDecls = mkHaskellConDecls hname attrs ty
+    dataType = 
+	 TyD $
+         TyDecl  (if isNewType then Newtype else Data)
+                 hname
+		 tvs
+	         (if isNewType then (map recToConDecl conDecls) else conDecls)
+		 derivings
+
+    derivings =
+      case findAttribute CustomAttributes.derivingAttr attrs of
+        Just (Attribute _ [ParamLit (StringLit s)]) -> map toQualName (split ',' s) ++ ds
+        _ -> ds
+
+    ds = addFlagDerivings $
+      case ty of
+         Enum _ kind vs |  genDerivedEnumInstanceFor kind vs && not forceFlag -> [enumClass]
+	 _ -> []
+
+    addFlagDerivings
+     | not optGenNumInstance && not optGenBitsInstance = id
+     | forceFlag = \ x -> (eqClass:showClass:x)
+     | otherwise =
+       case ty of
+         Enum _ EnumFlags{} _ -> \ x -> (eqClass:showClass:x)
+	 _ -> id
+
+    forceFlag = optEnumsAsFlags || 
+    		attrs `hasAttributeWithName` CustomAttributes.flagAttr
+\end{code}
+
+%
+%
+<sect2>Constants
+<label id="sec:constants">
+<p>
+%
+%
+
+Generating the Haskell equivalent of a constant is pretty
+straightforward, just introduce a constant declaration (+ type signature)
+for it.
+
+\begin{code}
+cgConstant :: Id -> Type -> Type -> Expr -> CgM HDecl
+cgConstant i t o_t e = do
+  addExport (ieValue hname)
+  return (typeSig hname ty `andDecl` 
+          funDef  hname [] expr)
+ where
+   ty    = toHaskellTy True o_t
+   hname = mkHaskellVarName (idName i)
+   expr  = 
+        case t of
+	  WString{} -> funApp mkWString [coreToHaskellExpr e]
+	  String{}  -> coreToHaskellExpr e
+	  Integer{} -> coreToHaskellExpr e
+	  Char{}    -> coreToHaskellExpr e
+	  Float{}   -> coreToHaskellExpr e
+	  WChar{}   -> coreToHaskellExpr e -- this is currently mapped to Char, btw.
+	  Bool      -> coreToHaskellExpr e
+	  Octet     -> coreToHaskellExpr e
+	  Pointer{} -> funApp intToAddr [ coreToHaskellExpr e ]
+	  _	    -> error ("cgConstant: don't know how to handle constant of type: " ++ 
+	  		      showCore (ppType ty) ++ showParen True (shows (idName i)) "")
+
+\end{code}
+
+%
+%
+<sect2>Translating interfaces
+<label id="sec:translate:interface">
+<p>
+%
+%
+
+\begin{code}
+cgInterface :: Id -> InterfaceInherit -> [InterfaceDecl] -> CgM HDecl
+cgInterface if_nm inherit decls = setIfaceName iface_name $ do
+  let 
+      (iface_kind, is_bin)
+       | not (is_object || is_idispatch ) = 
+	    if (idAttributes if_nm) `hasAttributeWithName` "odl" then
+		(VTBLObject, True)
+	    else
+		if notNull decls || optCorba || optJNI then
+    		   (VTBLObject, True)
+		else
+		   (StdFFI, False)
+       | is_idispatch  = (ComIDispatch isDual, False)
+       | otherwise     = (VTBLObject, True)
+
+      the_decls_to_use
+       | is_idispatch =
+         case optIgnoreMethsUpto of
+	   Nothing -> decls
+	   Just x  -> 
+	     case break (isEqualMethod x) decls of
+	       (ds,[])   -> ds
+	       (ds,_:xs) -> 
+	           -- keep any typedefs, but remove the methods
+	          filter (not.isMethod) ds ++ xs
+       | otherwise = decls
+
+      isEqualMethod x d = isMethod d && idOrigName (declId d) == x
+        
+
+  if is_bin && optDon'tGenBinaryComInterfaces then
+      trace ("Ignoring (binary) interface: "++ show iface_name) $
+      return emptyDecl
+   else do
+  setInterfaceFlag iface_kind $ do
+  setIEnumFlag is_ienum       $ do
+  setMethodNumber startOffset
+  body <- setIfaceAttributes attrs (mapM coGen the_decls_to_use)
+  let typeInSepModule = optOneModulePerInterface && notNull deps
+  when typeInSepModule $ do
+	 let ty_mod_nm = idName if_nm ++ "Ty"
+         addVitalExport (ieModule ty_mod_nm)
+         when (optNoExportList) (addVitalExport (ieModule (idName if_nm)))
+	 addExplicitImports [(False, ty_mod_nm)]
+
+  ud   <- 
+     if is_javeh_interface then do
+         c <- cgJNIInterface if_nm typeInSepModule
+	 return (infoHeader (Interface if_nm False inherit the_decls_to_use) `andDecl` c)
+      else if is_javeh_class then do
+         c <- cgJNIClass if_nm typeInSepModule
+	 d <- setInterfaceFlag VTBLObject (uuidDecl if_nm inh Iid)
+	 let
+	  ds 
+	   | typeInSepModule = infoHeader (Interface if_nm False inherit the_decls_to_use) `andDecl` c
+	   | otherwise       = infoHeader (Interface if_nm False inherit the_decls_to_use) `andDecl` d `andDecl` c
+	 return ds
+       else if typeInSepModule then do
+	 return emptyDecl
+        else do
+         d <- uuidDecl if_nm inh Iid
+	 return (infoHeader (Interface if_nm False inherit the_decls_to_use) `andDecl` d)
+
+  return (andDecls (ud:body))
+ where
+   is_javeh_interface = optJNI && not is_javeh_class
+   is_javeh_class     = optJNI && attrs `hasAttributeWithName` CustomAttributes.jniClassAttr
+
+   attrs      = idAttributes if_nm
+
+   iface_name = idName if_nm
+   deps       = findDeps if_nm
+
+   coGen d
+    | isMethod d = do
+         d' <- cgDecl d
+	 incMethodNumber
+	 return d'
+    | otherwise  = cgDecl d
+	    
+   startOffset
+    | iface_name == "IUnknown" = 0
+    | otherwise		       = sum (map snd inh)
+
+   isDual = attrs `hasAttributeWithName` "dual"
+
+      {-
+        Figuring out what kind of interface we've been presented with
+	is a little bit involved:
+	 
+	  - if iface has [oleautomation] attr ==> it's an IDispatch thing.
+	  - [dual] 			      ==> IDispatch
+	  - inherits from IDispatch derived iface  ==> IDispatch
+	  - [object] (but none of the above)  ==> IUnknown (binary invoc., really.)
+	  - [odl] (but none of the above)     ==> same.
+
+        Whether the generated stubs for IDispatch interfaces are declared
+	as being dual should use Invoke() or binary invocation is controlled
+	by the -fdual-vtbl (optDualVtbl) flag.
+      -}
+
+   is_object = 
+      attrs `hasAttributeWithName` "object" ||
+      any (\ x -> qName (fst x) == "IUnknown") inherit
+
+      -- extremely simplistic..
+   is_ienum = 
+       not optNoEnumMagic &&
+       ("IEnum" `isPrefixOf` iface_name &&
+        (length (filter isMethod decls)) == 4 &&
+        ok_looking_enum_names)
+  
+   -- Dear, oh dear. ToDo: control this with a cmd-line switch instead.
+   ok_looking_enum_names =
+      case (map (idName.declId) (filter isMethod decls)) of
+	['r':'e':'m':'o':'t':'e':'N':'e':'x':'t':_
+	 ,'s':'k':'i':'p':_, 'r':'e':'s':'e':'t':_
+	 ,'c':'l':'o':'n':'e' : _
+	 ] -> True
+	['n':'e':'x':'t':_
+	 ,'s':'k':'i':'p':_, 'r':'e':'s':'e':'t':_
+	 ,'c':'l':'o':'n':'e' : _
+	 ] -> True
+        _ -> False
+
+   is_idispatch = 
+       -- Not right, [oleautomation] only constrains the set of valid types.
+       --is_oleaut	           ||
+       (isDual && not optDualVtbl) ||
+       (any (\ x -> qName (fst x) == "IDispatch" &&
+       		    iface_name    /= "IDispatchEx") inherit &&
+       not (isDual && optDualVtbl))
+
+   inh =
+    case inherit of
+      []  | optCorba -> [(cObject, 0)]
+          | optHaskellToC || idName if_nm == "IUnknown" -> []
+	  | otherwise		       -> [(iUnknown, 3)]
+      xs@((x,_):_)
+	   -- if we've decided that we're processing an 
+	   -- Automation interface, but we've got an IUnknown
+	   -- in our hand as the interface we're inheriting from.
+	   -- Ignore, and pretend it's an IDispatch instead.
+	| is_idispatch && (not is_object) && qName x == "IUnknown" -> 
+	        trace ("Odd, interface " ++ show (idName if_nm) ++ 
+		       "inherits from IUnknown, but has been classified as an Automation interface\n" ++
+		       "(it will be treated as an Automation interface.)") 
+		[(iDispatch, 7)]
+	   -- special case for IUnknown:
+	| is_object && idName if_nm == "IUnknown" -> []
+	| otherwise -> map toStdNames xs
+	   where
+	     -- Just to make sure that we're using them 
+	     -- in a proper qualified manner...
+	    toStdNames (n,meths) = 
+		case (qName n) of
+{- Ensuring that re-defns of these two are short-circuited to the
+   library-provided impls, is now done by the desugarer. 
+   
+   ToDo: delete this once we're certain that this catches all of 'em.
+		  "IDispatch" -> (iDispatch,7)
+		  "IUnknown"  -> (iUnknown,3)
+-}
+		  nm          -> (n{qName=mkIfaceTypeName nm}, meths)
+\end{code}
+
+
+\begin{code}
+
+data GuidKind 
+ = Iid | Clsid | Libid 
+   deriving ( Eq )
+
+uuidDecl :: Id -> InterfaceInherit -> GuidKind -> CgM HDecl
+uuidDecl i inherit guidKind = do
+ flg       <- getInterfaceFlag
+ forClient <- getClientFlag
+ case flg of
+   StdFFI | forClient -> do
+     addExport (ieType tycon_nm optExportAbstractly)
+     decls <- marshallAbstract i
+     return (abs_ty `andDecl` decls)
+   _       -> do
+     case (getUuidAttribute attrs) of
+       Nothing  
+        | guidKind == Iid  -> do
+	   addExport (ieType iface_ptr_ty_nm False)
+           addExport (ieType i_tycon_nm_dummy False)
+	   ds <- 
+	      if null inherit && optHaskellToC then do
+	         ds <- marshallAbstract i
+		 return ( abs_ty `andDecl` ds)
+	       else
+	         return emptyDecl
+	     
+	   return ( ds 		   `andDecl`
+	            iface_dummy_ty `andDecl`
+		    iface_ptr_ty
+		  )
+	| otherwise -> return emptyDecl
+
+       Just guid -> do
+	   when (guidKind == Iid) (addExport (ieType iface_ptr_ty_nm True))
+           when (guidKind == Iid && not_iunknown) (addExport (ieType i_tycon_nm_dummy True))
+	   when (not no_libids) (addExport (ieValue iid_name))
+	   return (iface_dummy_ty `andDecl` 
+		   iface_ptr_ty   `andDecl`
+		   iid_def)
+	  where
+	   no_libids    = guidKind == Libid && (optNoLibIds || optUseStdDispatch)
+
+	   iid_name     = iid_prefix ++ iface_ptr_ty_nm
+	   iid_def  
+	    | no_libids = emptyDecl
+	    | otherwise = iid_tysig `andDecl` iid_decl
+
+	   iid_tysig    = typeSig iid_name (iid_tycon iid_tycon_args)
+	   iid_decl     = funDef iid_name [] iid_rhs
+	   iid_tyarg    = 
+		tyCon
+		  iface_ptr_ty_nm
+		  (if not optSubtypedInterfacePointers then
+		      []
+		   else
+		      [mkTyConst groundInterface])
+
+	   iid_rhs = funApp mk_iid [lit (StringLit ('{':(concat (intersperse "-" guid)) ++ "}"))]
+
+	   iid_tycon_args =case guidKind of { Iid -> [iid_tyarg] ; _   -> [] }
+
+	   mk_iid  =
+	    case guidKind of
+	      Iid   -> mkIID 
+	      Clsid -> mkCLSID
+	      Libid -> mkLIBID
+
+	   (iid_prefix, iid_tycon) =
+	    case guidKind of
+	       Iid    -> ("iid",   mkTyCon iID)
+	       Clsid  -> ("clsid", \ _ -> mkTyConst cLSID)
+	       Libid  -> ("libid", \ _ -> mkTyConst lIBID)
+
+
+      where
+         not_iunknown = idName i /= "IUnknown"
+
+          {-
+	    For interface 'ITest', we generate:
+	    
+	       data Test  a = Test__
+	       type ITest a = IUnknown (Test a)
+	       
+	    where 'IUnknown' is the interface ITest inherits from.
+	  -}
+	 iface_dummy_ty 
+            | (guidKind /= Iid)  = emptyDecl
+	    | isAuto && optUnparamedInterfacePointers  = tySyn i_tycon_nm [] (mkTyConst iDispatch)
+	    | optSubtypedInterfacePointers = 
+	       case idName i of
+		"IUnknown" -> emptyDecl  -- it's in a library.
+	        _          -> dataTy (i_tycon_nm_dummy) ["a"] [conDecl (i_tycon_nm++"__") []]
+	    | otherwise = emptyDecl
+
+	 iface_ptr_ty
+	    | (guidKind /= Iid) = emptyDecl -- coclass decl doesn't get a type syn.
+	    | optSubtypedInterfacePointers =
+		case idName i of
+		  "IUnknown"             -> 
+		  	tySyn iface_ptr_ty_nm ["a"] (mkTyCon iUnknown [tyVar "a"])
+		  _ | notNull inherit -> 
+		  	tySyn iface_ptr_ty_nm ["a"]
+			      (mkTyCon inh_from [tyCon (i_tycon_nm_dummy) [tyVar "a"]])
+		    | otherwise          ->
+		        emptyDecl
+
+            | null inherit = emptyDecl
+	    | otherwise    = tySyn iface_ptr_ty_nm [] (mkTyConst inh_from)
+
+         i_tycon_nm_dummy = i_tycon_nm ++ "_"
+
+	 isAuto = 
+	   case flg of
+	     ComIDispatch _ -> True
+	     _		    -> False
+
+         iface_ptr_ty_nm 
+	    | guidKind == Iid  = mkIfaceTypeName (idName i)
+	    | otherwise        = mkHaskellTyConName (idName i)
+
+	 inh_from = 
+	   let q_nm = fst (head inherit) in
+	   case qName q_nm of
+	    "IUnknown" | isDual -> iDispatch 
+			 -- I'm not kidding - this kind of bogosity
+			 -- does appear in Real Life.
+	    _  -> q_nm
+
+ where
+   -- drop common prefixes from the (disp)interface/coclass name..
+  i_tycon_nm = mkHaskellTyConName (mkIfaceTypeName (idName i))
+
+  attrs      = idAttributes i
+  tycon_nm   = mkHaskellTyConName (idName i)
+
+  abs_ty_args  = 
+    case findAttribute CustomAttributes.tyArgsAttr attrs of
+      Just (Attribute _ [ParamLit (StringLit s)]) -> words s
+      _ -> []
+
+  abs_ty = newTy tycon_nm abs_ty_args (conDecl tycon_nm [the_abs_ty]) derivings
+  
+  abs_ty_h = tyCon tycon_nm (map tyConst abs_ty_args)
+
+  isDual = attrs `hasAttributeWithName` "dual"
+
+  derivings =
+    case findAttribute CustomAttributes.derivingAttr attrs of
+      Just (Attribute _ [ParamLit (StringLit s)]) -> map toQualName (split ',' s)
+      _ -> []
+
+  the_abs_ty 
+    | attrs `hasAttributeWithName` CustomAttributes.finaliserAttr
+    = tyForeignPtr abs_ty_h
+    | otherwise = tyPtr abs_ty_h
+
+
+findDeps :: Id -> [String]
+findDeps i = map remove $  filterAttributes attrs ["depender"]
+  where
+   remove (Attribute _ [ParamLit (LitLit s)]) = s
+   remove _				      = ""
+
+   attrs = idAttributes i
+\end{code}
+
+%
+%
+<sect2>Translating dispinterfaces
+<label id="sec:translate:dispinterface">
+<p>
+%
+%
+
+Very much like the translation of a `normal' interface:
+
+\begin{code}
+cgDispInterface :: Id -> Maybe Decl -> [Decl] -> [Decl] -> CgM HDecl
+cgDispInterface i ii props meths = 
+    withIfaceInherit [iUnknown,iDispatch]  $
+    setIfaceName (idName i)                $
+    inDispInterface			   $
+    setInterfaceFlag (ComIDispatch False)  $ do
+    is_src   <- getSourceIfaceFlag
+    let is_source = is_src || hasSourceAttribute (idAttributes i)
+    setSourceIfaceFlag is_source $ do
+    forClient <- getClientFlag
+    body <- mapM cgDecl (props ++ meths)
+    ud   <- uuidDecl i [(iDispatch,7)] Iid
+    if is_source && optIgnoreSourceIfaces then
+        return (infoHeader (DispInterface i ii props meths) `andDecl` ud)
+     else do
+     {-
+      It may look a bit funny to generate a VTBL for a
+      dispinterface server too, but that's how we implement
+      'em. The type library based IDispatch marshaller needs to
+      be passed a method table.
+     -}
+      vtbl <- 
+        if (forClient && not is_source) || (not forClient && is_source) then
+            return emptyDecl
+         else
+	    let
+	      is_wrapper = isJust ii
+	      stuff = 
+	        case ii of
+		  Just (Interface{declDecls=ds}) -> ds
+		  _ -> props ++ meths
+            in
+            mkServVTBL i (is_source || optUseStdDispatch) is_wrapper stuff
+
+      return (infoHeader (DispInterface i ii props meths) `andDecl`
+              ud				          `andDecl`
+	      vtbl				          `andDecl`
+              andDecls body
+	     )
+    
+\end{code}
+
+%
+%
+<sect2>Translating coclasses
+<label id="sec:translate:dispinterface">
+<p>
+%
+%
+
+If we're splitting up the IDL input up into one Haskell module per (disp)interface,
+a coclass declaration gives rise to a Haskell module that re-exports the interfaces
+it implements plus it defines its CLSID.
+
+\begin{code}
+cgCoClass :: Id -> [CoClassDecl] -> CgM HDecl
+cgCoClass i cdecls 
+ | optOneModulePerInterface = do
+     don't_gen_code_for_cls <-
+       case cdecls of
+         [x] | isJust (coClassDecl x) -> 
+	    hoistInClass (idName (coClassId x)) $ \ mb_cls ->
+	    return (isJust mb_cls)
+	 _ -> return False
+
+     if don't_gen_code_for_cls then
+        return emptyDecl
+      else do
+        addExplicitImports import_modules
+        sequence (map (addExport.ieModule.snd) import_modules)
+        ud <- setInterfaceFlag (ComIDispatch False) (uuidDecl i [] Clsid)
+        return (prettyPrint ud)
+
+ | otherwise = do
+     forClient <- getClientFlag
+     ud        <- setInterfaceFlag (ComIDispatch False) (uuidDecl i [] Clsid)
+     body      <-
+        if (not forClient) then
+	   getDeclName $ \ lib_nm ->
+           mkServMain lib_nm i cdecls
+	else
+	   return emptyDecl
+     return ( prettyPrint ud `andDecl` body)
+
+ where
+  import_modules = map (\ x -> (True, idName (coClassId x))) the_cdecls
+
+   -- weed out the dispinterfaces, if we've been told to do so.
+  isIface CoClassInterface{} = True
+  isIface _		     = False
+
+  the_cdecls
+    | optIgnoreDispInterfaces = filter (isIface) cdecls
+    | otherwise		      = cdecls
+
+  prettyPrint d  = infoHeader (CoClass i cdecls) `andDecl` d 
+
+\end{code}
+
+\begin{code}
+cgLibrary :: Id -> [Decl] -> CgM HDecl
+cgLibrary i lib_decls = 
+   withDeclName (idName i) $ do
+     ud <- setInterfaceFlag (ComIDispatch False) (uuidDecl i [] Libid)
+     ds <- mapM cgDecl lib_decls
+     return ( prettyPrint ud `andDecl` andDecls ds)
+ where
+  prettyPrint d 
+   | optNoLibIds = emptyDecl
+   | otherwise   = infoHeader (Library i lib_decls) `andDecl` d 
+
+\end{code}
+
+
+%
+%
+<sect2>Translating modules
+<label id="sec:translate:module">
+<p>
+%
+%
+
+Translating a module isn't too much work, set the flag
+to indicate that we're processing 'static' decls inside
+the module and tell everyone what DLL it's coming from
+(if any.)
+
+\begin{code}
+cgModule :: Id -> [Decl] -> CgM HDecl
+cgModule i ds =
+   setInterfaceFlag StdFFI $ 
+   withDeclName (idName i) $ 
+   mbSetDllName		   $ do
+       hs <- mapM cgDecl ds
+       return (infoHeader (Module i ds) `andDecl` andDecls hs)
+  where
+   mbSetDllName x = 
+     case (findAttribute CustomAttributes.dllNameAttr (idAttributes i)) of
+       (Just (Attribute _ [ParamLit (StringLit s)])) -> setDllName s x
+       _ -> x
+
+\end{code}
+
+
+%
+%
+<sect2>Translating types
+<label id="sec:translate:type">
+<p>
+%
+%
+
+Converting an IDL type into its Haskell equivalent. The translation
+is in some cases guided by attributes, e.g., the presence of the
+`string' attribute turns char* into a `String'.
+
+\begin{code}
+mkHaskellConDecls :: Name -> [Attribute] -> Type -> [ConDecl]
+mkHaskellConDecls nm attrs ty =
+  map (groundTys) $ 
+  case ty of
+   Enum _ k vals          -> mkHEnumDef  nm attrs k vals
+   Union _ _ _ _ switches -> mkHUnionDef nm switches
+   UnionNon _    switches -> mkHUnionDef nm switches
+   CUnion _ fields _ -> mkCUnionDef fields
+   Struct tag mem _  -> [mkHStructDef tag mem]
+
+    -- [abstract] is undoc'ed and will probably disappear soon,
+    -- don't use..
+   Pointer _ _ Iface{}
+      | attrs `hasAttributeWithName` CustomAttributes.abstractAttr
+      -> [ConDecl nm [Unbanged abs_ty]]
+	where
+	  abs_ty 
+	   | attrs `hasAttributeWithName` CustomAttributes.finaliserAttr
+	   = tyForeignObj
+	   | otherwise = tyAddr
+	      
+   Pointer pt _ t ->
+       case pt of 
+         Ptr    -> [ConDecl "Ptr" [Unbanged (toHaskellTy True t)]]
+         Ref    -> mkHaskellConDecls nm attrs t
+         Unique -> [ConDecl "Maybe" [Unbanged (toHaskellTy True t)]]
+   _ -> let
+	 str = showAbstractH (ppType (toHaskellTy True ty))
+	in
+	trace ("mkHaskellConDecls: odd argument: " ++ str)
+	      [ConDecl str []]
+ where
+   -- remove any left-over 
+  groundTys (ConDecl n bs) = ConDecl n (map groundBangTy bs)
+  groundTys (RecDecl n rs) = RecDecl n (map (\ (i,t) -> (i,groundBangTy t)) rs)
+  
+  groundBangTy (Banged t)   = Banged   (groundTyVars t)
+  groundBangTy (Unbanged t) = Unbanged (groundTyVars t)
+
+\end{code}
+
+Top level function for creating code for (constructed)
+IDL types:
+
+ * we don't generate any marshalling code for the different
+   IDL pointer types. Instead, we provide parameterised marshallers
+   in a library and just parameterise them approp. when we need
+   to swizzle pointers to/from the outside world. i.e., we're
+   interested in keeping the size of the generated code down.
+
+\begin{code}
+cgMarshallTy :: Id -> Type -> CgM HDecl
+cgMarshallTy i ty =
+ case ty of
+  Struct tag members mb_pack -> 
+    case (mkHaskellConDecls (idName tag) (idAttributes tag) ty) of
+      [cdecl]       ->  marshallStruct (idName i) tag cdecl members mb_pack
+      _             -> error "cgMarshallTy{Struct}: expected one condecl"
+  Enum _ k fields   -> marshallEnum i k (genDerivedEnumInstanceFor k fields) fields
+  Union _ tag_ty tag _ sws ->
+      marshallUnion (idName i) (Left (tag,tag_ty)) False sws Nothing
+  UnionNon tag sws ->
+    let
+     as     = idAttributes i ++ idAttributes tag
+     tag_ty = getTagTy as
+    in
+    marshallUnion (idName i) (Right tag_ty) False sws Nothing
+
+  CUnion tag fields mb_pack ->
+    let
+     as     = idAttributes i ++ idAttributes tag
+     tag_ty = getTagTy as
+
+     switches = map fieldToSwitch fields
+     
+     fieldToSwitch (Field fi t ot _ _) =  Switch fi labs t ot
+        where
+	  labs = 
+	    case findAttribute "case" (idAttributes i) of
+	      Just (Attribute _ ls) -> mapMaybe toCase ls
+	      _			    -> []
+
+     toCase (ParamExpr e) = Just (Case e)
+     toCase (ParamVar v)  = Just (Case (Var v))
+     toCase _	          = Nothing
+    in
+    marshallUnion (idName i) (Right tag_ty) True{-is C union-} switches mb_pack
+
+  FunTy _ _ _  -> marshallFun Nothing i ty
+  _            -> return emptyDecl
+ where
+  getTagTy as = 
+	case findAttribute "switch_type" as of
+	  Just (Attribute _ [ParamType t])	 -> t
+	  _ ->
+		case getSwitchIsAttribute as of
+		   Just (Cast t _) -> t
+		   _ -> Integer Long True
+
+\end{code}
+
+\begin{code}
+marshallServ :: Id 
+	     -> InterfaceInherit
+	     -> [InterfaceDecl]
+	     -> CgM HDecl
+marshallServ ifaceId inherit decls = do
+  let 
+      iface_kind
+       | not (isObject || isIDispatch ) = 
+	    if attrs `hasAttributeWithName` "odl" || optCorba || optJNI then
+		VTBLObject
+	    else
+	        StdFFI
+       | isIDispatch  = ComIDispatch isDual
+       | otherwise    = VTBLObject
+
+  setInterfaceFlag iface_kind $ do
+  setIfaceName iface_name     $ do
+  is_src <- getSourceIfaceFlag
+  setMethodNumber startOffset
+  body <- mapM coGen decls
+  ud   <- 
+      if is_javeh_interface then
+         return emptyDecl
+       else 
+         uuidDecl ifaceId inherit Iid
+  vtbl <- 
+     if optJNI then
+       cgJClass ifaceId decls
+     else
+       mkServVTBL ifaceId (is_src && isIDispatch) False decls
+  return (infoHeader (Interface ifaceId False inherit decls) `andDecl`
+          ud						     `andDecl`
+	  vtbl						     `andDecl`
+          andDecls body)
+
+ where
+  iface_name = idName ifaceId
+  attrs	     = idAttributes ifaceId
+
+  is_javeh_interface = optJNI && not is_javeh_class
+  is_javeh_class     = optJNI && attrs `hasAttributeWithName` CustomAttributes.jniClassAttr
+
+  coGen d
+   | isMethod d = do
+         d' <- cgDecl d
+	 incMethodNumber
+	 return d'
+   | otherwise  = cgDecl d
+
+  startOffset
+   | iface_name == "IUnknown" = 0
+   | otherwise		      = sum (map snd inherit)
+
+  isIDispatch = 
+      (isDual && not optDualVtbl) ||
+      (any (\ x -> qName (fst x) == "IDispatch" && 
+      		   iface_name /= "IDispatchEx") inherit && not (isDual && optDualVtbl))
+
+  isDual   = attrs `hasAttributeWithName` "dual"
+  isObject = attrs `hasAttributeWithName` "object" ||
+	     any (\ x -> qName (fst x) == "IUnknown") inherit
+
+\end{code}
+ src/CoreIDL.lhs view
@@ -0,0 +1,341 @@+% 
+% (c) The Foo Project, Universities of Glasgow & Utrecht, 1997-8
+%
+% @(#) $Docid: Nov. 16th 2001  17:13  Sigbjorn Finne $
+% @(#) $Contactid: sof@galconn.com $
+%
+
+The CoreIDL interface defines the intermediate representation
+used for IDL specifications.
+
+\begin{code}
+module CoreIDL where
+
+import Literal
+import BasicTypes
+import Int ( Int32 )
+import TypeInfo
+\end{code}
+
+\begin{code}
+data Decl
+  = Typedef       { declId :: Id, declType :: Type, declOrigType :: Type }
+  | Constant      { declId       :: Id
+  		  , declType     :: Type
+		  , declOrigType :: Type
+		  , declExpr     :: Expr
+		  }
+  | Interface     { declId :: Id
+		  , isReference :: Bool -- => True, not a defining occurrence, but a use.
+					-- need to make the distinction when dealing with
+					--
+					--    library {  interface IA; ... } 
+					-- 
+					-- and 
+					-- 
+					--    dispinterface { interface IA; }
+					--
+		  , declInherit :: InterfaceInherit
+		  , declDecls :: [InterfaceDecl]
+		  }
+  | Module        { declId :: Id, declDecls :: [ModuleDecl]  }
+  | DispInterface { declId :: Id
+		  , dispExpandedFrom :: Maybe Decl 
+		          -- Just IA => expanded from "dispinterface DA { interface IA; };"
+                  , declProps :: [DispInterfaceDecl]
+		  , declDecls :: [DispInterfaceDecl]
+		  }
+  | CoClass       { declId :: Id, declCoDecls :: [CoClassDecl] }
+  | Library       { declId :: Id, declDecls :: [LibraryDecl] }
+  | Method        { declId :: Id
+		  , methCallConv :: CallConv
+		  , methResult   :: Result
+		  , methParams   :: [Param]
+		  , methOffset   :: Maybe Int   -- used by type libraries only.
+		  }
+  | Property      { declId     :: Id
+  		  , declType   :: Type
+		  , propOffset :: Maybe Int
+		  , declSetId  :: Id
+		  , declGetId  :: Id
+		  }
+  | HsLiteral	  String -- literal Haskell code.
+  | CInclude	  String
+  | CLiteral	  String -- literal C code (used when generating header files from IDL spec.)
+
+type InterfaceDecl     = Decl
+  -- Typedef, Constant, Method
+
+type ModuleDecl        = Decl
+  -- Constant, Method
+
+type DispInterfaceDecl = Decl
+  -- Method, Property
+
+data CoClassDecl 
+ = CoClassInterface     { coClassId :: Id, coClassDecl :: Maybe Decl }
+ | CoClassDispInterface { coClassId :: Id, coClassDecl :: Maybe Decl }
+
+type LibraryDecl       = Decl
+  -- any (apart from Library)
+
+type InterfaceInherit = 
+   [( QualName
+    , Int	    -- Just x => interface contains m methods.
+    )]
+
+\end{code}
+
+\begin{code}
+data Expr
+ = Binary BinaryOp Expr Expr
+ | Cond   Expr Expr Expr
+ | Unary  UnaryOp Expr
+ | Var    Name
+ | Lit    Literal
+ | Cast   Type Expr
+ | Sizeof Type
+   deriving ( Eq
+{-
+-- trick to get conditional code blocks work
+-- for Haskell systems that do/do not offer CPP preprocessing.
+-- (for systems that don't (i.e. Hugs), the code block will be
+-- used.
+#ifdef DEBUG
+-}
+	    , Show
+{-
+#endif
+-}
+	    )
+\end{code}
+
+The type language for Core IDL:
+
+\begin{code}
+data Type
+ = Integer Size Signed
+ | StablePtr
+ | FunTy   CallConv Result [Param]
+ | Float   Size
+ | Char    Signed
+ | WChar
+ | Bool   | Octet | Any  | Object
+ | String Type Bool (Maybe Expr) | WString Bool (Maybe Expr)
+ | Sequence Type (Maybe Expr) (Maybe Expr)
+ | Fixed Expr IntegerLit
+ | Name     Name
+ 	    Name		-- original name
+ 	    (Maybe Name)	-- where it is defined.
+	    (Maybe [Attribute]) -- the attributes at its definition site.
+	    (Maybe Type)	-- the type it expands to.
+	    (Maybe TypeInfo)    -- custom/off-line type info.
+
+ | Struct   Id 
+            [Field]
+	    (Maybe Int)		-- packed (in bytes.)
+
+ | Enum     Id EnumKind [EnumValue]
+ | Union    Id Type Id Id [Switch]
+ | UnionNon Id [Switch]    -- non-encapsulated union.
+ | CUnion   Id [Field]     -- C-style union
+	       (Maybe Int) -- packed (in bytes.)
+
+ | Pointer  PointerType
+ 	    Bool           -- True  => pointer type was explicitly given
+	                   -- False => not explicit, default type.
+ 	    Type
+ | Array    Type [Expr]
+ | Void
+ | Iface    Name              -- an interface/abstract type
+	    (Maybe Name)      -- the module it was imported from.
+ 	    Name	      -- it's original name
+	    [Attribute]       -- attributes used at definition site.
+	    Bool	      -- True => derives from IDispatch.
+	    InterfaceInherit  -- what it extends (in *reverse* order, i.e., base iface comes first, since
+			      -- we're mostly interested in the iface/object's base when marshalling.)
+
+     -- the following are only produced in MS IDL mode:
+ | SafeArray Type
+   deriving ( Eq
+{-
+#ifdef DEBUG
+-}
+	    , Show
+{-
+#endif
+-}
+	    )
+
+type Signed = Bool
+
+\end{code}
+
+In Core, we pin attributes on Ids: 
+
+\begin{code}
+data Id 
+ = Id {
+      idName       :: Name,	    -- a unique, Haskellised name
+      idOrigName   :: Name,	    -- source name
+      idModule     :: Maybe Name,   -- where it is defined, Nothing => local.
+      idAttributes :: [Attribute]
+   }
+   deriving ( Eq
+{-
+#ifdef DEBUG
+-}
+	    , Show
+{-
+#endif
+-}
+	    )
+
+\end{code}
+
+
+\begin{code}
+data Attribute 
+ = AttrMode ParamDir
+ | AttrDependent {
+      atReason    :: DepReason,
+      atParams    :: [AttributeParam]
+   }
+ | Attribute {
+      atName      :: Name,
+      atParams    :: [AttributeParam]
+   } 
+   deriving ( Eq
+{-
+#ifdef DEBUG
+-}
+	    , Show
+{-
+#endif
+-}
+	    )
+
+data AttributeParam
+ = ParamLit    Literal
+ | ParamType   Type
+ | ParamExpr   Expr
+ | ParamVar    Name
+ | ParamVoid
+ | ParamPtr AttributeParam
+    deriving ( Eq
+{-
+#ifdef DEBUG
+-}
+	     , Show
+{-
+#endif
+-}
+	     )
+
+data DepReason
+ = SizeIs  | LengthIs
+ | LastIs  | FirstIs
+ | MaxIs   | MinIs
+ | SwitchIs
+   deriving ( Eq, Show )
+\end{code}
+
+\begin{code}
+data Result =
+   Result { 
+     resultType     :: Type,  -- used 
+     resultOrigType :: Type
+   }  
+     deriving ( Eq
+{-
+#ifdef DEBUG
+-}
+	      , Show
+{-
+#endif
+-}
+	      )
+
+data Param
+ = Param {
+     paramId        :: Id,
+     paramMode      :: ParamDir,
+     paramType      :: Type,  -- used for marshalling purposes
+     paramOrigType  :: Type,  -- un-reduced version.
+     paramDependent :: Bool
+   }
+     deriving ( Eq
+{-
+#ifdef DEBUG
+-}
+	      , Show
+{-
+#endif
+-}
+	      )
+
+data Switch    
+ = Switch {
+     switchId	    :: Id,
+     switchLabels   :: [CaseLabel],
+     switchType     :: Type,
+     switchOrigType :: Type
+   } 
+ | SwitchEmpty  (Maybe [(CaseLabel,String)]) 
+                            -- Nothing      => default switch.
+			    -- Just [(x,y)] => y is the tag name.
+   deriving ( Eq
+{-
+#ifdef DEBUG
+-}
+	    , Show
+{-
+#endif
+-}
+	    )
+
+data CaseLabel 
+ = Case Expr | Default
+   deriving ( Eq
+{-
+#ifdef DEBUG
+-}
+	    , Show
+{-
+#endif
+-}
+	    )
+
+-- for struct & C union fields
+data Field 
+ = Field {
+     fieldId       :: Id,
+     fieldType     :: Type,
+     fieldOrigType :: Type,
+     fieldSize     :: Maybe Int,
+     fieldOffset   :: Maybe Int
+   } deriving ( Eq
+{-
+#ifdef DEBUG
+-}
+	      , Show
+{-
+#endif
+-}
+	      )
+
+data EnumValue 
+ = EnumValue {
+     enumName  :: Id,
+     enumValue :: (Either Int32 Expr)
+   } deriving ( Eq
+{-
+#ifdef DEBUG
+-}
+	      , Show
+{-
+#endif
+-}
+	      )
+
+\end{code}
+ src/CoreUtils.lhs view
@@ -0,0 +1,2024 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 9th 2003  15:15  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+A hodgepodge of helper functions over the CoreIDL data types.
+
+\begin{code}
+module CoreUtils 
+	(
+	  mkId
+	, setIdModule
+	, mkParam
+	
+	, flattenDecls
+	, reallyFlattenDecls
+	, inSeparateHaskellModule
+	, findFieldTy
+	, findFieldOrigTy
+	, findParam
+	, findParamTy
+	
+	, localiseTypes
+	
+	, getTypeAttributes        -- :: Type -> [Attribute]
+	, getHsImports             -- :: Id   -> [QualName]
+
+	, keepValueAsPointer
+
+	, isStructTy
+	, isEnumTy
+	, isPointerTy
+	, isVoidPointerTy
+	, isArrayTy
+	, isSafeArrayTy
+	, isOpenArrayTy
+	, isFunTy
+	, isBoolTy
+	, isVoidTy
+	, isPointerOrArrayTy
+	, isPtrPointerTy
+	, isRefPointerTy
+	, isUniquePointerTy
+	, isStringTy
+	, isSeqTy
+	, isAnyTy
+	, isObjectTy
+	, isConstructedTy
+	, isCompleteTy
+	, isReferenceTy
+	, isSimpleTy
+	, isIntegerTy
+	, isSynTy
+	, isAbstractTy
+	, isAbstractFinalTy
+	, isNonEncUnionTy
+	, getNonEncUnionTy
+	, isUnionTy
+	, isIfaceTy
+	, isIUnknownTy
+	, isIfacePtr
+	, isVariantTy
+	, getIfaceTy
+
+	, tyFun
+	, stringTy
+	, wStringTy
+	, bstrTy
+	, intTy
+	, addrTy
+	, boolTy
+	, variantBoolTy
+	, variantTy
+	, charTy
+	, wCharTy
+	, int32Ty
+	, int64Ty
+	, word64Ty
+	, shortTy
+	, floatTy
+	, doubleTy
+	, byteTy
+	, word32Ty
+	, int16Ty
+	, word16Ty
+	, voidTy
+	, currencyTy
+	, dateTy
+	, fileTimeTy
+	, safeArrayTy
+	
+	, iUnknownTy
+	, iDispatchTy
+	, hresultTy
+	, guidTy
+	, isHRESULTTy   -- :: Type   -> Bool
+	, isHRESULT     -- :: Result -> Bool
+
+	, mkPtrPointer
+	, removePtr
+	, removePtrAndArray
+	, removePtrAll
+	, removePtrs
+	, removeNames
+	, nukeNames
+	, pushPointerType
+	, hasIgnoreAttribute
+	, findPtrType
+	, mkRefPointer
+	, rawPointerToIP
+        , notAggregatableAttribute
+	, childAttributes
+	
+	, getTyTag
+	, findFreeVars
+	, solve
+	, complementOp
+	, isCommutative
+	, contains
+	, evalExpr
+	, simplifyExpr
+	, simpRedExpr
+
+	, plusOne
+	, minusOne
+	, add
+	
+	, sizeofType
+	, sizeAndAlignModulus
+	, computeStructSizeOffsets
+	, align
+
+	, Dependent(..)
+	, DepVal(..)
+	, DependInfo
+	, findDependents
+	, attrToDependent
+	, computeArrayConstraints
+
+	, isLengthIs
+	, isSizeIs
+	, isMaxIs
+	, isMinIs
+	, isFirstIs
+	, isLastIs
+	, sizeOrLength
+	, minOrFirst
+	, maxOrLast
+	, isSwitchIs
+	, lookupDepender
+	, isDepender
+	, isDependee
+	, isSwitchDependee
+	, isSwitchDepender
+	, isNotSwitchDependee
+	, hasNonConstantExprs
+
+	, mkHaskellVarName
+	, mkHaskellTyConName
+
+	, toCType
+	
+	, mkIfaceTypeName
+	, getInterfaceIds      -- :: Decl -> [Id]
+	
+	, idHaskellModule
+	
+	, isMethod
+	, isConst
+	, isMethodOrProp
+	, isProperty
+	, isCoClass
+	
+	, dummyMethod
+	
+	, unionToStruct
+	
+	, binParams
+	, objParam
+	, resultParam
+	, iPointerParam
+	
+	, derivesFromIDispatch
+	, toDispInterfaceMethod
+
+	, sortDecls
+	
+	, isFinalisedType
+	
+	) where
+
+import CoreIDL
+import BasicTypes ( Name, Size(..), BinaryOp(..), ShiftDir(..)
+		  , PointerType(..), UnaryOp(..), ParamDir(..)
+		  , CallConv, qName, qDefModule, qModule, QualName
+		  , toQualName, qOrigName
+		  )
+import Attribute
+import Literal
+import LibUtils
+import Opts   ( optOneModulePerInterface, optNoDependentArgs,
+	        optDeepMarshall, optHaskellToC, optClassicNameMangling,
+		optLongLongIsInteger, optPointerDefault
+	      )
+import PpCore ( ppType, showCore, ppExpr )
+import Digraph
+import Utils
+
+import Maybe  ( mapMaybe, fromMaybe, mapMaybe, isJust )
+import List   ( partition )
+import Char   ( toLower, toUpper, isLower, isUpper, isAlpha, isDigit )
+import TypeInfo
+import NativeInfo
+import Env
+import Int
+import List
+import Bits
+{- BEGIN_GHC_ONLY
+import GlaExts
+   END_GHC_ONLY -}
+	
+\end{code}
+
+\begin{code}
+mkId :: Name -> Name -> Maybe Name -> [Attribute] -> Id
+mkId nm orig_nm md attrs = Id nm orig_nm md attrs
+
+setIdModule :: Maybe Name -> Id -> Id
+setIdModule md i = i{idModule=md}
+\end{code}
+
+\begin{code}
+mkParam :: Name -> ParamDir -> Type -> Param
+mkParam nm mode ty = Param (mkId nm nm Nothing noAttrs) mode ty ty False
+\end{code}
+
+\begin{code}
+isHRESULT :: Result -> Bool
+isHRESULT res = isHRESULTTy (resultOrigType res)
+\end{code}
+
+
+Lifting contents of modules and libraries to the top.
+
+\begin{code}
+flattenDecls :: [Decl] -> [Decl]
+flattenDecls ls = flatDecls True inSeparateHaskellModule ls
+
+flatDecls :: Bool
+	  -> (Decl -> Bool)
+	  -> [Decl]
+	  -> [Decl]
+flatDecls _ _ [] = []
+flatDecls isTopLev predic (Module i ds : rs) = 
+   ( lift ++ (Module i don't_lift : flatDecls isTopLev predic rs) )
+    where (lift, don't_lift) = partition predic ds 
+flatDecls isTopLev predic (Library i ds : rs)
+    | not isTopLev = Library i ds : flatDecls isTopLev predic rs
+    | otherwise    = (Library i don't_lift) : lift ++ flatDecls False predic rs
+    where 
+     (lift, don't_lift) = partition (\ x -> predic x && not (isLibrary x)) ds 
+
+     isLibrary (Library _ _) = True
+     isLibrary _	     = False
+flatDecls isTopLev predic (d:ds) = d : flatDecls isTopLev predic ds
+
+reallyFlattenDecls :: [Decl] -> [Decl]
+reallyFlattenDecls ls = flatDecls True (\ _ -> True) ls
+
+-- True => put the generated contents of IDL declaration in
+--         separate Haskell module.
+inSeparateHaskellModule :: Decl -> Bool
+inSeparateHaskellModule Module{}        = True
+inSeparateHaskellModule Library{}       = True
+inSeparateHaskellModule DispInterface{} = optOneModulePerInterface
+inSeparateHaskellModule Interface{}     = optOneModulePerInterface
+inSeparateHaskellModule CoClass{}       = optOneModulePerInterface
+inSeparateHaskellModule _	        = False
+
+{-
+ If we're splitting up the input into multiple Haskell
+ modules, minimise the scope of types/constants. i.e.,
+ iff a type is only used within one interface (==module),
+ float it into that interface.
+-}
+localiseTypes :: [Decl] -> [Decl]
+localiseTypes ds 
+ | not optOneModulePerInterface = ds
+ | otherwise = --trace (show (map fst $ envToList moveEnv, envToList uniqueEnv, allTD_Names)) $
+               mapMaybe moveTypes ds
+  where
+    moveTypes d@Typedef{declId=i}
+      | isJust (lookupEnv uniqueEnv (idName i)) = Nothing
+      | otherwise = Just d
+    moveTypes (Module i ds1)  = 
+        let ds' = mapMaybe moveTypes ds1 in
+	case lookupEnv moveEnv (idName i) of
+	   Just ts -> Just (Module i (map (adjustMod (idName i) ts) (ts ++ ds')))
+           _ -> Just (Module i ds')
+    moveTypes (Library i ds1) = 
+        let ds' = mapMaybe moveTypes ds1 in
+	case lookupEnv moveEnv (idName i) of
+	   Just ts -> Just (Library i (map (adjustMod (idName i) ts) (ts ++ ds')))
+           _ -> Just (Library i ds')
+    moveTypes d@(Interface{declId=i}) =
+       case lookupEnv moveEnv (idName i) of
+          Just ts -> Just d{declDecls=map (adjustMod (idName i) ts) (ts ++ declDecls d)}
+	  _ -> Just d
+    moveTypes d@(DispInterface{declId=i}) =
+       case lookupEnv moveEnv (idName i) of
+          Just ts -> Just d{declDecls=map (adjustMod (idName i) ts) (ts ++ declDecls d)}
+	  Nothing -> Just d
+    moveTypes d = Just d
+    
+    adjustMod nm ls d = foldl adj d ls
+      where
+        adj acc Typedef{declId=i} = adjustModName (idName i) nm acc
+
+    moveEnv :: Env String{-type name-}
+    		   [Decl] {- _declarations_ to be added-}
+    moveEnv = addListToEnv_C (++)
+    			     newEnv
+    		             (mapMaybe findDecl (envToList uniqueEnv))
+     where
+       findDecl (nm,use) = 
+         case find (withName nm) typesMoving of
+	   Just d  -> Just (use,[d])
+	   Nothing -> Nothing
+
+       withName nm (Typedef{declId=i}) = idName i == nm || idOrigName i == nm
+       withName _ _ = False
+
+    typesMoving = filter isMoving allTDs
+      where
+       isMoving Typedef{declId=i} = isJust (lookupEnv uniqueEnv (idName i))
+       isMoving _                 = False
+
+    allTD_Names = map (idName.declId) allTDs
+
+    allTDs = concatMap allTypedefs ds
+     where
+       allTypedefs d = 
+          case d of
+	   Typedef{}     -> [d]
+           Module _ ds1  -> concatMap allTypedefs ds1
+	   Library _ ds1 -> concatMap allTypedefs ds1
+	   Interface{declDecls=ds1}     -> concatMap allTypedefs ds1
+	   DispInterface{declDecls=ds1} -> concatMap allTypedefs ds1
+	   _            -> []
+
+
+     -- environment mapping type names to the name of the _only_ 
+     -- declaration that uses it.
+    uniqueEnv :: Env String{-used type name-}
+    		     String{-where it is used-}
+    uniqueEnv = mapMaybeEnv isOfInterest useEnv
+      where
+       isOfInterest _ ls  =
+          case nub ls of
+	     [x] | x `notElem` allTD_Names -> Just x -- only interested if it was used at a
+	     					     -- a non typedef-site (=> in an interface).
+	     _ -> Nothing
+       isOfInterest _ _   = Nothing
+
+    useEnv :: Env String   {- used type name -}
+                  [String] {- names of decls that uses type -}
+    useEnv = foldl addIt newEnv use_info
+      where
+        addIt env (_decl,d,us) = foldl (addUse d) env us
+	addUse nm env use     = addToEnv_C (++) env use [nm]
+	   
+    use_info = concatMap mkDeps ds
+     where
+       mkDeps d = 
+         case d of 
+	   Module  _ ds1 -> concatMap mkDeps ds1
+	   Library _ ds1 -> concatMap mkDeps ds1
+	   _             -> [mkDeclDep d]
+
+
+adjustModName :: String -> String -> Decl -> Decl
+adjustModName nm newMod d = 
+  case d of
+    Typedef i ty oty  -> Typedef i (adjustType ty) (adjustType oty)
+    Constant i ty oty e -> Constant i (adjustType ty) (adjustType oty) e
+    Interface i flg inh ds -> Interface i flg (map adjustInherit inh) 
+    					      (map (adjustModName nm newMod) ds)
+    DispInterface i expF ps ds -> DispInterface i (fmap (adjustModName nm newMod) expF)
+    						  (map  (adjustModName nm newMod) ps)
+    						  (map  (adjustModName nm newMod) ds)
+    Module i ds  -> Module i (map (adjustModName nm newMod) ds)
+    Library i ds -> Module i (map (adjustModName nm newMod) ds)
+    Method i cc res ps off -> Method i cc (adjustResult res) (map adjustParam ps) off
+    Property i ty off si gi -> Property i (adjustType ty) off si gi
+    _ -> d
+ where
+   adjustResult (Result ty oty) = Result (adjustType ty) (adjustType oty)
+   adjustParam p@Param{paramType=ty,paramOrigType=oty} =
+   	p{paramType=adjustType ty,paramOrigType=adjustType oty}
+
+   adjustInherit (qnm,i) = (adjustQName qnm, i)
+   
+   adjustQName qnm 
+     | qName qnm == nm ||
+       qOrigName qnm == nm = qnm{qModule=Just newMod,qDefModule=Just newMod}
+     | otherwise = qnm
+
+   adjustType ty = 
+      case ty of
+        Integer{} -> ty
+	StablePtr{} -> ty
+        FunTy cc res ps -> FunTy cc (adjustResult res) (map adjustParam ps)
+	Float{} -> ty
+	Char{}  -> ty
+	WChar{} -> ty
+	Bool{}  -> ty
+	Octet{}  -> ty
+	Any{}  -> ty
+	Object{}  -> ty
+	String t flg mb -> String (adjustType t) flg mb
+	WString{} -> ty
+	Fixed{}   -> ty
+	Name n onm mbMod attrs mbTy mbTi 
+	  | n == nm   -> Name n onm (Just newMod) attrs (fmap adjustType mbTy) mbTi
+	  | otherwise -> Name n onm mbMod attrs (fmap adjustType mbTy) mbTi
+        Struct i fs p -> Struct i (map adjustField fs) p
+	Enum{}        -> ty
+	Union i ty1 a b sws -> Union i (adjustType ty1) a b (map adjustSwitch sws)
+	UnionNon i sws -> UnionNon i (map adjustSwitch sws)
+	CUnion i fs p -> CUnion i (map adjustField fs) p
+	Pointer p flg t -> Pointer p flg (adjustType t)
+	Array t e     -> Array (adjustType t) e
+	Void{}        -> ty
+	Iface n md onm attrs flg ih 
+	  | n == nm || onm == nm -> Iface n (Just newMod) onm attrs flg (map adjustInherit ih)
+	  | otherwise -> Iface n md onm attrs flg (map adjustInherit ih)
+        SafeArray t   -> SafeArray (adjustType t)
+
+   adjustField f@Field{fieldType=ty,fieldOrigType=oty} = f{fieldType=adjustType ty,
+   							   fieldOrigType=adjustType oty
+							   }
+   adjustSwitch s@SwitchEmpty{} = s
+   adjustSwitch s@Switch{switchType=ty,switchOrigType=oty} = s{switchType=adjustType ty,
+   							       switchOrigType=adjustType oty}
+
+isMethod :: Decl -> Bool
+isMethod Method{} = True
+isMethod _	  = False
+
+isConst :: Decl -> Bool
+isConst Constant{} = True
+isConst _	   = False
+
+isMethodOrProp :: Decl -> Bool
+isMethodOrProp Method{}   = True
+isMethodOrProp Property{} = True
+isMethodOrProp _	  = False
+
+isProperty :: Decl -> Bool
+isProperty Property{}       = True
+isProperty Method{declId=i} = 
+  attrs `hasAttributeWithNames` ["propget", "propput", "propputref"]
+
+ where
+  attrs = idAttributes i
+isProperty _ = False
+
+isCoClass :: Decl -> Bool
+isCoClass CoClass{} = True
+isCoClass _	    = False
+
+\end{code}
+
+\begin{code}
+dummyMethod :: Decl
+dummyMethod = Method (mkId "dummy" "dummy" Nothing [])
+		     defaultCConv
+		     (Result hresultTy hresultTy)
+		     [{-no params-}]
+		     Nothing
+\end{code}
+
+\begin{code}
+getInterfaceIds :: Decl -> [Id]
+getInterfaceIds decl = reverse (go [] decl)
+ where
+   go acc d = 
+     case d of
+	Interface{} -> foldl go ((declId d):acc) (declDecls d)
+	Module _ ds -> foldl go acc ds
+	DispInterface{} -> foldl go ((declId d):acc) (declDecls d)
+	Library _ ds    -> foldl go acc ds
+	_ -> acc
+
+\end{code}
+
+\begin{code}
+findFieldTy :: [Field] -> Name -> Type
+findFieldTy [] nm = error ("findFieldTy: " ++ nm) -- not supposed to happen.
+findFieldTy (f : xs) nm
+ | nm == idName (fieldId f) = fieldType f
+ | otherwise                = findFieldTy xs nm
+
+findFieldOrigTy :: [Field] -> Name -> Type
+findFieldOrigTy [] nm = error ("findFieldOrigTy: " ++ nm) -- not supposed to happen.
+findFieldOrigTy (f : xs) nm
+ | nm == idName (fieldId f) = fieldOrigType f
+ | otherwise                = findFieldOrigTy xs nm
+
+findParam :: [Param] -> Name -> Param
+findParam []	   nm	    = error ("findParam: " ++ nm) -- not supposed to happen.
+findParam (p : xs) nm
+ | nm == idName (paramId p) = p
+ | otherwise		    = findParam xs nm
+
+findParamTy :: [Param] -> Name -> Type
+findParamTy ps nm = paramType (findParam ps nm)
+
+\end{code}
+
+Fish out attributes attached to type:
+
+\begin{code}
+getTypeAttributes :: Type -> [Attribute]
+getTypeAttributes ty = 
+  case ty of 
+    Name _ _ _ mb_as mb_ty _  -> fromMaybe [] mb_as ++
+    			         fromMaybe [] (fmap getTypeAttributes mb_ty)
+    Struct i _ _ -> idAttributes i
+    Enum i _ _   -> idAttributes i
+    Union i _ _ _ _ -> idAttributes i
+    UnionNon i _    -> idAttributes i
+    CUnion i _ _    -> idAttributes i
+    Pointer _ _ t  -> getTypeAttributes t
+    Iface _ _ _ as _ _ -> as
+    _ -> []
+
+\end{code}
+
+The [hs_import(qualName)] is used on IDL module declarations to
+have 'qualName' be imported in the corresponding Haskell module.
+Normally only used in conjunction with hs_quote(..) declarations &
+you don't want to write all the import declarations yourself.
+
+\begin{code}
+getHsImports :: Id -> [QualName]
+getHsImports i = imp_attrs
+ where
+  imp_attrs = mapMaybe toHsImport attrs
+
+  attrs = filterAttributes (idAttributes i) ["hs_import"]
+  
+  toHsImport :: Attribute -> Maybe QualName
+  toHsImport a =
+    case a of
+      Attribute _ [ParamLit (StringLit s)] ->
+         let qNm = toQualName s in
+         case qModule qNm of 
+	   Nothing -> Nothing
+	   Just _  -> Just (qNm{qDefModule=qModule qNm})
+      _ -> Nothing
+
+\end{code}
+
+\begin{code}
+isStructTy :: Type -> Bool
+isStructTy Struct{} = True
+isStructTy (Name _ _ _ _ (Just t) _) = isStructTy t
+isStructTy _	    = False
+
+isEnumTy   :: Type -> Bool
+isEnumTy Enum{} = True
+isEnumTy (Name _ _ _ _ (Just t) _) = isEnumTy t
+isEnumTy _      = False
+
+isPointerTy :: Type -> Bool
+isPointerTy Pointer{} = True
+isPointerTy _	      = False
+
+isVoidPointerTy :: Type -> Bool
+isVoidPointerTy (Pointer _ _ Void) = True
+isVoidPointerTy (Name _ _ _ _ (Just t) _) = isVoidPointerTy t
+isVoidPointerTy _	         = False
+
+{-
+ keepValueAsPointer is used to determine whether
+ we should unmarshall a parameter/result coming
+ back from a method.
+
+ The policy is as follows:
+   - pointer to a struct or union is held back
+     as an external value.
+   - pointers to basic types, strings,
+     arrays are unmarshalled into the Haskell heap.
+-}
+keepValueAsPointer :: Type -> Bool
+keepValueAsPointer ty
+  | optDeepMarshall = False
+  | otherwise       =
+     case ty of
+	Pointer _ _ (Name _ _ _ _ Nothing  _) -> True
+	Pointer _ _ (Name _ _ _ _ (Just t) _) -> keepValueAsPointer t
+	Pointer _ _ Struct{}       -> True
+	Pointer _ _ Union{}        -> True
+	Pointer _ _ UnionNon{}     -> True
+	Pointer _ _ CUnion{}       -> True
+	_                          -> False
+
+isArrayTy :: Type -> Bool
+isArrayTy Array{}     = True
+isArrayTy (Name _ _ _ _ (Just t) _) = isArrayTy t
+isArrayTy _           = False
+
+isSafeArrayTy :: Type -> Bool
+isSafeArrayTy SafeArray{}  = True
+isSafeArrayTy (Name _ _ _ _ (Just t) _) = isSafeArrayTy t
+isSafeArrayTy _           = False
+
+isOpenArrayTy :: Type -> Bool 
+isOpenArrayTy (Array _ []) = True
+isOpenArrayTy _		   = False
+
+isBoolTy :: Type -> Bool
+isBoolTy Bool  = True
+isBoolTy (Name _ _ _ _ (Just t) _) = isBoolTy t
+isBoolTy _     = False
+
+isFunTy :: Type -> Bool
+isFunTy FunTy{} = True
+isFunTy (Name _ _ _ _ (Just t) _) = isFunTy t
+isFunTy _              = False
+
+isVoidTy :: Type -> Bool
+isVoidTy Void  = True
+isVoidTy (Name _ _ _ _ (Just t) _) = isVoidTy t
+isVoidTy _     = False
+
+isPointerOrArrayTy :: Type -> Bool
+isPointerOrArrayTy ty = isPointerTy ty || isArrayTy ty
+
+isPtrPointerTy  :: Type -> Bool
+isPtrPointerTy (Pointer Ptr _ _) = True
+isPtrPointerTy _	         = False
+
+isRefPointerTy :: Type -> Bool
+isRefPointerTy (Pointer Ref _ _) = True
+isRefPointerTy _	         = False
+
+mkRefPointer :: Type -> Type
+mkRefPointer (Pointer _ expl t) = Pointer Ref expl t
+mkRefPointer (Name nm onm md a (Just ty) mb_ti) = Name nm onm md a (Just (mkRefPointer ty)) mb_ti
+mkRefPointer t = t
+
+-- convert the (innermost) void* into an interface pointer.
+-- (used when a [iid_is()] is in effect.
+rawPointerToIP :: Type -> Type
+rawPointerToIP (Pointer _ _ Void)  = Pointer Ref True iUnknownTy
+rawPointerToIP (Pointer pt expl t) = Pointer pt expl (rawPointerToIP t)
+rawPointerToIP (Name nm onm md a (Just ty) mb_ti) =
+   Name nm onm md a (Just (rawPointerToIP ty)) mb_ti
+rawPointerToIP t = t
+
+isUniquePointerTy :: Type -> Bool
+isUniquePointerTy (Pointer Unique _ _) = True
+isUniquePointerTy _                    = False
+
+isStringTy :: Type -> Bool
+isStringTy String{}  = True
+isStringTy WString{} = True
+isStringTy (Name _ _ _ _ _ (Just ti)) = qName (haskell_type ti) == stringName
+isStringTy _	     = False
+
+isSeqTy :: Type -> Bool
+isSeqTy Sequence{} = True
+isSeqTy (Name _ _ _ _ (Just t) _) = isSeqTy t
+isSeqTy _          = False
+
+isAnyTy :: Type -> Bool
+isAnyTy Any = True
+isAnyTy _   = False
+
+isObjectTy :: Type -> Bool
+isObjectTy Object		   = True
+isObjectTy (Name _ _ _ _ (Just t) _) = isObjectTy t
+isObjectTy _			   = False
+
+intTy :: Type
+intTy = Integer Natural True{-Signed-}
+
+addrTy :: Type
+addrTy = Pointer Ptr True Void
+
+charTy :: Type
+charTy = Char False{-Unsigned-}
+
+wCharTy :: Type
+wCharTy = WChar
+
+boolTy :: Type
+boolTy = Bool
+
+-- built-in Automation type
+variantBoolTy :: Type
+variantBoolTy = Name "VARIANT_BOOL" "VARIANT_BOOL" Nothing Nothing Nothing Nothing
+
+variantTy :: Type
+variantTy = Name "VARIANT" "VARIANT" autoLib Nothing Nothing (Just variant_ti)
+
+int32Ty :: Type
+int32Ty = Integer Long True{-Signed-}
+
+int64Ty :: Type
+int64Ty = Integer LongLong True{-Signed-}
+
+word64Ty :: Type
+word64Ty = Integer LongLong False{-unsigned-}
+
+word32Ty :: Type
+word32Ty = Integer Long False{-Unsigned-}
+
+word16Ty :: Type
+word16Ty = Integer Short False{-Unsigned-}
+
+int16Ty :: Type
+int16Ty = Integer Short True{-Signed-}
+
+voidTy :: Type
+voidTy = Void
+
+currencyTy :: Type
+currencyTy = Name  "CURRENCY" "CURRENCY" autoLib Nothing Nothing mb_currency_ti
+
+dateTy :: Type
+dateTy = Name "DATE" "DATE" autoLib Nothing (Just int64Ty) mb_date_ti
+
+fileTimeTy :: Type
+fileTimeTy = Name "FILETIME" "FILETIME" Nothing Nothing Nothing Nothing
+
+safeArrayTy :: Type -> Type
+safeArrayTy t = SafeArray t
+
+shortTy :: Type
+shortTy = Integer Short True{-signed-}
+
+byteTy :: Type
+byteTy = Char False
+
+floatTy :: Type
+floatTy = Float Short
+
+doubleTy :: Type
+doubleTy = Float Long
+
+stringTy :: Type
+stringTy = String (Char False) False Nothing
+
+wStringTy :: Type
+wStringTy = WString False Nothing
+
+bstrTy :: Type
+bstrTy = Name "BSTR" "BSTR" comLib Nothing Nothing (Just bstr_ti)
+
+iUnknownTy :: Type
+iUnknownTy = Iface "IUnknown" comLib "IUnknown" [] False []
+
+iDispatchTy :: Type
+iDispatchTy = Iface "IDispatch" autoLib "IDispatch" [] True [(iUnknown,3)]
+
+hresultTy :: Type
+hresultTy = Name "HRESULT" "HRESULT" comLib Nothing (Just int32Ty) Nothing
+
+isHRESULTTy :: Type -> Bool
+isHRESULTTy (Name "HRESULT" _ _ _ _ _) = True
+isHRESULTTy _			       = False
+
+guidTy :: Type
+guidTy = Name "GUID" "GUID" comLib Nothing Nothing Nothing
+
+-- weird name, funTy is already taken, I'm afraid.
+tyFun :: CallConv -> Result -> [Param] -> Type
+tyFun = FunTy
+
+\end{code}
+
+\begin{code}
+mkPtrPointer :: Type -> Type
+mkPtrPointer (Pointer _ _ t) = Pointer Ptr True t
+mkPtrPointer (Array t [])    = Pointer Ptr True t
+mkPtrPointer t		     = t
+
+removePtr :: Type -> Type
+removePtr t@(Pointer _ _ Void) = t
+removePtr (Pointer _ _ t)      = t
+removePtr t                    = t
+
+removePtrAndArray :: Type -> Type
+removePtrAndArray t@(Pointer _ _ Void) = t
+removePtrAndArray (Pointer _ _ t)    = t
+removePtrAndArray (Array t _)        = t
+removePtrAndArray t                  = t
+
+removePtrAll :: Type -> Type
+removePtrAll t@(Pointer _ _ Void) = t
+removePtrAll (Pointer _ _ t)      = t
+removePtrAll (Array t _)          = t
+removePtrAll (String t _ _)       = t
+removePtrAll WString{}            = WChar
+removePtrAll t                    = t
+
+removePtrs :: Type -> Type
+removePtrs (Pointer _ _ t) = removePtrs t
+removePtrs t               = t
+
+removeNames :: Type -> Type
+removeNames t@(Name _ _ _ _ _ (Just _)) = t
+removeNames (Name _ _ _ _ (Just t) _) | not (isConstructedTy t) = removeNames t
+removeNames t = t
+
+nukeNames :: Type -> Type
+nukeNames t@(Name _ _ _ _ _ (Just _)) = t
+nukeNames (Name _ _ _ _ (Just t) _)  = nukeNames t
+nukeNames t = t
+
+pushPointerType :: PointerType -> Type -> Type
+pushPointerType pt (Pointer _ expl ty) = Pointer pt expl ty
+pushPointerType _  ty	     = ty
+
+\end{code}
+
+\begin{code}
+hasIgnoreAttribute :: Id -> Bool
+hasIgnoreAttribute i = idAttributes i `hasAttributeWithName` "ignore"
+
+childAttributes :: [Attribute] -> [Attribute]
+childAttributes as = filter (not.notAggregatableAttribute) as
+
+notAggregatableAttribute :: Attribute -> Bool
+notAggregatableAttribute (AttrMode _) = False
+notAggregatableAttribute (AttrDependent _ _) = False
+notAggregatableAttribute (Attribute nm _) = nm `elem` junk_list
+  where
+   junk_list =
+     [ "helpstring"
+     , "helpcontext"
+--     , "pointer_default"
+     , "dllname"
+     , "lcid"
+     , "odl"
+     , "restricted"
+     , "ole"
+     , "uuid"
+     , "object"
+     , "oleautomation"
+     , "hidden"
+     , "version"
+     , "local"
+     , "custom"
+     , "public"
+     , "dual"
+     , "switch_type"
+     , "switch_is"
+     , "depender"
+     , "ty_params"
+     , "jni_interface"
+     , "jni_iface_ty"
+     , "jni_class"
+     , "hs_name"
+     , "hs_import"
+     , "hs_newtype"
+     ]
+
+\end{code}
+
+\begin{code}
+isConstructedTy :: Type -> Bool
+isConstructedTy Struct{}   = True
+isConstructedTy Enum{}     = True
+isConstructedTy Union{}    = True
+isConstructedTy UnionNon{} = True
+isConstructedTy CUnion{}   = True
+isConstructedTy FunTy{}    = True
+isConstructedTy _          = False
+
+{-
+ only used on constructed types.
+-}
+isCompleteTy :: Type -> Bool
+isCompleteTy (Struct _ ls _)    = notNull ls
+isCompleteTy (Enum _ _ ls)      = notNull ls
+isCompleteTy (Union _ _ _ _ ls) = notNull ls
+isCompleteTy (UnionNon _ ls )   = notNull ls
+isCompleteTy (CUnion _ ls _)    = notNull ls
+isCompleteTy (Name _ _ _ _ (Just t) _) = isCompleteTy t
+isCompleteTy FunTy{}            = True
+isCompleteTy _			= False
+
+isReferenceTy :: Type -> Bool
+isReferenceTy = not.isCompleteTy
+\end{code}
+
+What is a simple IDL type? This predicate is currently
+only used by the code that implements the translation
+of type(def) declarations, determining whether to use
+a type synonym or data declaration to represent the
+Haskell repr of the IDL type.
+
+\begin{code}
+isSimpleTy :: Type -> Bool
+isSimpleTy ty =
+ case ty of
+   Sequence{}        -> False -- for now.
+   Fixed{}           -> False
+   Struct{}          -> False
+   Enum{}            -> False
+   Union{}           -> False
+   UnionNon{}        -> False
+   CUnion{}          -> False
+   Array{}           -> False
+   SafeArray{}       -> False
+   Pointer{}         -> False
+   String {}         -> False
+   WString{}         -> False
+   Bool		     -> False
+   FunTy{}	     -> False
+   Name _ _ _ _ _ (Just _) -> False -- bit of a sweeping statement.
+   Name _ _ _ _ Nothing  _ -> False
+   Name _ _ _ _ (Just t) _ -> isSimpleTy t
+   Iface{}           -> not optHaskellToC
+   Integer LongLong _ -> not optLongLongIsInteger
+   _                 -> True
+
+isIntegerTy :: Type -> Bool
+isIntegerTy (Integer LongLong _) = optLongLongIsInteger
+isIntegerTy _			 = False
+
+isSynTy :: Type -> Bool
+isSynTy Name{} = True
+isSynTy _      = False
+
+isAbstractTy :: Type -> Bool
+isAbstractTy Iface{} = optHaskellToC 
+isAbstractTy (Pointer _ _ Iface{}) = optHaskellToC
+isAbstractTy _		 = False
+
+isAbstractFinalTy :: Type -> Bool
+isAbstractFinalTy (Iface _ _ _ attrs _ _)
+  = optHaskellToC && attrs `hasAttributeWithName` "finaliser"
+isAbstractFinalTy (Pointer _ _ (Iface _ _ _ attrs _ _)) 
+  = optHaskellToC && attrs `hasAttributeWithName` "finaliser"
+isAbstractFinalTy _
+  = False
+
+isNonEncUnionTy :: Type -> Bool
+isNonEncUnionTy t = have_a_look t
+  where
+   have_a_look ty =
+     case ty of
+       UnionNon{}      -> True
+       CUnion{}        -> True
+       Name _ _ _ _ (Just tt) _ -> have_a_look tt
+       _	              -> False
+
+{-
+ Invariant: always called on a ty for which 'isNonEncUnionTy'
+            returned True.
+-}
+getNonEncUnionTy :: Type -> Type
+getNonEncUnionTy t = look_around t
+ where
+   look_around ty =
+     case ty of
+       UnionNon{}      -> ty
+       CUnion{}        -> ty
+       Name _ _ _ _ (Just tt) _ -> look_around tt
+       _	              ->
+          error "getNonEncUnionTy: you've reached unreachable code (..oops!)"
+
+isUnionTy :: Type -> Bool
+isUnionTy t = have_a_look t
+  where
+   have_a_look ty =
+     case ty of
+       Union{}      -> True
+       UnionNon{}   -> True
+       CUnion{}     -> True
+       Name _ _ _ _ (Just tt) _ -> have_a_look tt
+       _	              -> False
+
+
+-- peer through names and pointers to see if there's an interface hiding here somewhere.
+isIfaceTy :: Type -> Bool
+isIfaceTy (Name _ _ _ _ (Just t) _) = isIfaceTy t
+isIfaceTy (Pointer _ _ t)         = isIfaceTy t
+isIfaceTy Iface{}		  = True
+isIfaceTy _		          = False
+
+isIUnknownTy :: Type -> Bool
+isIUnknownTy (Name _ _ _ _ (Just t) _) = isIUnknownTy t
+isIUnknownTy (Pointer _ _ t)         = isIUnknownTy t
+isIUnknownTy (Iface "IUnknown" _ _ _ _ _) = True
+isIUnknownTy (Iface _ _ _ _ flg _) = not flg
+isIUnknownTy _			   = False
+
+isIfacePtr :: Type -> Bool
+isIfacePtr (Name _ _ _ _ (Just t) _) = isIfacePtr t
+isIfacePtr (Pointer _ _ (Iface{})) = True
+isIfacePtr (Pointer _ _ t) = 
+  case (removeNames t) of
+    Iface{} -> True
+    _       -> False
+isIfacePtr _			   = False
+
+
+getIfaceTy :: Type -> Type
+getIfaceTy (Name _ _ _ _ (Just t) _) = getIfaceTy t
+getIfaceTy (Pointer _ _ t)	   = getIfaceTy t
+getIfaceTy t@Iface{}		   = t
+getIfaceTy _			   = error "getIfaceTy: should never happen"
+
+isVariantTy :: Type -> Bool
+isVariantTy (Name "VARIANT" _ _ _ _ _) = True
+isVariantTy (Name _ _ _ _ (Just t) _)  = isVariantTy t
+isVariantTy _ = False
+
+\end{code}
+
+\begin{code}
+getTyTag :: Type -> Id
+getTyTag (Enum i _ _)       = i
+getTyTag (Struct i _ _)     = i
+getTyTag (Union i _ _ _ _)  = i
+getTyTag (UnionNon i _)     = i
+getTyTag (CUnion i _ _)     = i
+getTyTag (Name n onm md attrs _ _) = mkId n onm md (fromMaybe [] attrs)
+getTyTag (Pointer _ _ t)    = getTyTag t
+getTyTag t                  = error ("getTyTag: not supposed to be given this type as arg!" ++ showCore (ppType t))
+\end{code}
+
+\begin{code}
+findFreeVars :: Expr -> [Name]
+findFreeVars (Var v)          = [v]
+findFreeVars (Lit _)          = []
+findFreeVars (Sizeof _)       = []
+findFreeVars (Cast _ e)       = findFreeVars e
+findFreeVars (Unary _ e)      = findFreeVars e
+findFreeVars (Binary _ e1 e2) = findFreeVars e1 ++ findFreeVars e2
+findFreeVars (Cond e1 e2 e3)  = findFreeVars e1 ++ findFreeVars e2 ++ findFreeVars e3
+\end{code}
+
+A very simplistic expression solver, the variable we're solving for
+is given as first argument.
+
+\begin{code}
+solve :: Name -> Expr -> Expr -> Expr
+solve nm lhs (Cast _ e)     = solve nm lhs e
+solve nm lhs (Unary op rhs) = solve nm (Unary op lhs) rhs
+solve nm lhs (Binary op e1 e2) 
+ | contains nm e1 = solve nm (Binary op' lhs e2) e1
+ | isCommutative op && contains nm e2 = solve nm (Binary op' lhs e1) e2
+ | contains nm e2 = solve nm (Binary op e1 lhs) e2
+   where op' = complementOp op
+solve _ lhs _  = lhs
+
+complementOp :: BinaryOp -> BinaryOp
+complementOp Add = Sub
+complementOp Sub = Add
+complementOp Mul = Div
+complementOp Mod = Div
+complementOp Div = Mul
+complementOp Eq  = Ne
+complementOp Ne  = Eq
+complementOp And = Or
+complementOp Or  = And
+complementOp (Shift L) = Shift R
+complementOp (Shift R) = Shift L
+complementOp Gt  = Lt
+complementOp Ge  = Le
+complementOp Le  = Ge
+complementOp Lt  = Gt
+complementOp LogOr  = LogAnd
+complementOp LogAnd = LogOr
+complementOp Xor = Xor 
+
+isCommutative :: BinaryOp -> Bool
+isCommutative Add = True
+isCommutative Mul = True
+isCommutative _   = False
+
+contains :: Name -> Expr -> Bool
+contains nm (Var v) = v == nm
+contains nm (Cast _ e) = contains nm e
+contains nm (Unary _ e) = contains nm e
+contains nm (Binary _ e1 e2) = contains nm e1 || contains nm e2
+contains _  _ = False
+
+plusOne :: Expr -> Expr
+plusOne e = Binary Add e (Lit (iLit (1::Int)))
+
+minusOne :: Expr -> Expr
+minusOne e = Binary Sub e (Lit (iLit (1::Int)))
+
+add :: Expr -> Expr -> Expr
+add e1 e2 = Binary Add e1 e2
+\end{code}
+
+\begin{code}
+
+evalExpr :: Expr -> Integer
+evalExpr e = 
+ case e of
+    {-
+     In order to be correct, evaluation needs to 
+     be type driven
+    -}
+   Binary bop e1 e2 -> 
+      let 
+        i1 = evalExpr e1
+        i2 = evalExpr e2
+      in
+      case bop of
+        Add -> i1 + i2
+        Sub -> i1 - i2
+        Div -> i1 `div` i2
+        Mod -> i1 `mod` i2
+        Mul -> i1 * i2
+	Xor -> toInteger (fromInteger i1 `xor` ((fromInteger i2)::Int32)) -- an Bits instance for Integers, anyone?
+	Or  -> toInteger (fromInteger i1 .|.   ((fromInteger i2)::Int32))
+	And -> toInteger (fromInteger i1 .&.   ((fromInteger i2)::Int32))
+	Shift L -> toInteger (shiftL ((fromInteger i1)::Int32) (fromIntegral i2))
+	Shift R -> toInteger (shiftR ((fromInteger i1)::Int32) (fromIntegral i2))
+	LogAnd  -> if i1 /= 0 && i2 /=0 then 1 else 0
+	LogOr   -> if i1 /= 0 || i2 /=0 then 1 else 0
+	Gt  -> if i1 > i2 then 1 else 0
+	Ge  -> if i1 >= i2 then 1 else 0
+	Eq  -> if i1 == i2 then 1 else 0
+	Le  -> if i1 <= i2 then 1 else 0
+	Lt  -> if i1 <  i2 then 1 else 0
+	Ne  -> if i1 /= i2 then 1 else 0
+	
+   Cond e1 e2 e3 ->
+      let
+       i1 = evalExpr e1
+       i2 = evalExpr e2
+       i3 = evalExpr e3
+      in
+      if i1 == 0 then
+         i2
+      else
+         i3
+   Unary  uop e1 -> 
+      let
+       i1 = evalExpr e1
+      in
+      case uop of
+        Minus  -> -i1
+	Plus   -> i1
+	Not    -> if i1==0 then 1 else 0
+	Negate -> toInteger ((complement (fromInteger i1)) :: Int32)
+	Deref  -> i1
+   Var nm       -> error ("evalExpr: cannot handle free variable " ++ show nm)
+   Lit (IntegerLit (ILit _ i))  -> i
+   Cast _ e1     -> evalExpr e1
+   Sizeof t     -> fromIntegral (sizeofType t)
+   _ -> error ("CoreUtils.evalExpr: Unmatched case for: " ++ showCore (ppExpr e))
+ 
+\end{code}
+
+Expand out occurrences of @(Var x)@ and @(Sizeof t)@:
+
+\begin{code}
+
+simpRedExpr  :: Env String (Either Int32 Expr)
+	     -> Type
+	     -> Expr
+	     -> Expr
+simpRedExpr env ty ex = 
+   case (simplifyExpr env ex) of
+     e@(Lit _) -> e
+     e         -> 
+	 case ty of
+	   Integer _ _ -> Lit (iLit (evalExpr e))  -- reduce 'int'y things.
+	   _	       -> e
+
+simplifyExpr :: Env String (Either Int32 Expr)
+	     -> Expr
+	     -> Expr
+simplifyExpr val_env ex = 
+  case ex of
+    Binary bop e1 e2 -> Binary bop (simplifyExpr val_env e1)
+    				   (simplifyExpr val_env e2)
+    Cond e1 e2 e3 -> Cond (simplifyExpr val_env e1)
+    			  (simplifyExpr val_env e2)
+			  (simplifyExpr val_env e3)
+    Unary op e -> Unary op (simplifyExpr val_env e)
+    Var nm     -> 
+      case lookupEnv val_env nm of
+        Nothing        -> Var nm -- good luck!
+	Just (Left x)  -> Lit (iLit (toInteger x))
+	Just (Right e) -> e
+    Lit l      -> Lit l
+      -- notice that casting would have been trickier
+      -- to deal with if the expression language permitted
+      -- sizeof(x), where x is an expression, since 
+      -- sizeof((t)x) == sizeof(t) 
+    Cast t e   -> Cast t (simplifyExpr val_env e)
+    Sizeof t   -> Lit (iLit (toInteger (sizeofType t)))
+
+\end{code}
+
+@findDependents@ computes the attribute dependencies an identifier has
+on others, i.e., in DCE IDL, it is possible to express dependencies
+between field members and parameters. The dependencies encode what/how
+much of an array/pointer value should be marshalled between client
+and server. The attributes are:
+
+ first_is(params)   -- non-neg (array) index(es) of first element
+ last_is(params)    -- (array) index(es) of last element to be transmitted/received.
+ length_is(params)  -- number of elements of array that are to be transmitted/received.
+ max_is(params)     -- specifies upper bound for valid array indexes.
+ min_is(params)     -- lower bound (normally zero.)
+ size_is(params)    -- the allocation size of the array.
+
+where params is a list of expressions (arrays can be multi-dimensional.), some
+of which might be empty.
+
+@findDependents@ returns a list of identifiers, with each id paired with a list
+containing its dependencies.
+
+\begin{code}
+
+type DependInfo = [(Id,[Dependent])]
+
+data DepVal 
+ = DepNone  -- empty/unspecified (for this dimension.)
+ | DepVal (Maybe Name) -- a dependent value might contain at most one
+		       -- free variable which refers to another field/param.
+	  Expr	       -- 
+-- for debugging purps. only
+   deriving (Show)
+
+data Dependent = Dep DepReason [DepVal] -- a list, since the id might be multi-dimensional.
+                  deriving ( Show )
+
+{- BEGIN_GHC_ONLY
+-- For Hugs users, this instance will conflict with the one in CoreIDL.
+instance Show Expr where
+  show x = showCore (ppExpr x)
+  END_GHC_ONLY -}
+\end{code}
+
+\begin{code}
+findDependents :: [Id] -> DependInfo
+findDependents ls
+  | optNoDependentArgs = []
+  | otherwise	       = map (\ i -> (i, findDep i)) ls
+  where
+   findDep i = mapMaybe ((mapMb attrToDependent).isDependentAttribute)
+			(idAttributes i)
+
+attrToDependent :: Attribute -> Dependent
+attrToDependent (AttrDependent reason args) = Dep reason (map toDepVal args)
+  where
+   toDepVal (ParamLit  l@(IntegerLit _)) = DepVal Nothing (Lit l)  -- the only legal lit
+   toDepVal (ParamVar v)                 = DepVal (Just v) (Var v)
+   toDepVal (ParamExpr (Var v))          = DepVal (Just v) (Var v)
+   toDepVal ParamVoid			 = DepNone
+   toDepVal (ParamExpr e)		 =
+	-- Assume the expression has been checked
+	-- as having at most one free variable.
+	case (findFreeVars e) of
+	 []    -> DepVal Nothing  e
+	 (f:_) -> DepVal (Just f) e
+   toDepVal (ParamPtr p)		 =
+       case (toDepVal p) of
+         DepVal fv e  -> DepVal fv (Unary Deref e)
+	 d            -> d
+   toDepVal _ = DepNone
+
+attrToDependent _ = error "attrToDependent"
+\end{code}
+
+\begin{code}
+computeArrayConstraints :: Bool
+			-> [Dependent]
+			-> ([DepVal], [DepVal], [DepVal])
+computeArrayConstraints unmarshalling deps 
+ | unmarshalling = (trans_start_posns, trans_end_posns, trans_lengths)
+ | otherwise     = (trans_start_posns, trans_end_posns, alloc_sizes)
+ where
+
+    -- multiple traversals of the dependencies list here, but lists
+    -- are likely to be very short, so merging the passes into
+    -- one is likely to cost more than it saves.
+
+--not supported, and of little use 
+--when we're representing lists as arrays:
+-- mins    = filter isMinIs deps
+   maxs    = mapHead (\ (Dep _ ls) -> ls) $ filter isMaxIs deps
+   firsts  = mapHead (\ (Dep _ ls) -> ls) $ filter isFirstIs deps
+   lasts   = mapHead (\ (Dep _ ls) -> ls) $ filter isLastIs deps
+   lengths = mapHead (\ (Dep _ ls) -> ls) $ filter isLengthIs deps
+   sizes   = mapHead (\ (Dep _ ls) -> ls) $ filter isSizeIs deps
+
+   dimensions          = maximum (map length [maxs,firsts,lasts,lengths,sizes])
+
+   alloc_sizes         = zipWith  genUpperBound (fillInDims maxs) (fillInDims sizes)
+   trans_start_posns   = map      genLowerBound (fillInDims firsts)
+   trans_end_posns     = zipWith3 genEnd        (fillInDims lasts)   trans_lengths trans_start_posns
+   trans_lengths       = zipWith  genLength     (fillInDims lengths) alloc_sizes
+
+    -- generate the array indexes from which to start transmitting elements.
+    -- If none given for a dimension, start from zero.
+   genLowerBound DepNone = DepVal Nothing (Lit (iLit (0::Int)))
+   genLowerBound d       = d
+
+    -- generate expressions holding the lengths of transmittable ranges. The second
+    -- argument will not have any DepNone's in it.
+   genLength DepNone  d = d
+   genLength d        _ = d
+
+   {- The upper bound of what is to be transmitted is determined by
+      preferably looking at the last_is() attribute. If not present, we
+      derive its value as follows:   last_is = length + first - 1
+   -}
+   genEnd DepNone  (DepVal fv l) (DepVal _ f)
+     = DepVal fv (minusOne (add l f))  -- BUG: we're dropping a free variable here!
+   genEnd d	   _             _ = d
+
+   {- The upper allocation boundary is determined by looking at either the max_is()
+      or size_is(). max_is 
+   -}
+   genUpperBound DepNone      DepNone
+     = DepNone --error "genUpperBound: max_is nor size_is value not specified (need one of them.)"
+   genUpperBound (DepVal _ _) (DepVal _ _)
+     = error "genUpperBound: size_is and max_is both given for a dimension (not legal.)"
+   genUpperBound DepNone       d       = d
+   genUpperBound (DepVal fv e) DepNone = DepVal fv (plusOne e)
+
+   --mapHead :: (a -> [b]) -> [a] -> [b]
+   mapHead _ []    = []
+   mapHead f (x:_) = f x
+
+   --fillInDims :: [a] -> [a]
+   fillInDims ls = go dimensions ls
+     where
+      go 0 _      = []
+      go n (x:xs) = x:go (n-1) xs
+      go n []	  = DepNone:go (n-1) []
+
+\end{code}
+
+
+Predicates over dependency items and lists.
+
+\begin{code}
+isLengthIs, isSizeIs :: Dependent -> Bool
+isSizeIs   (Dep SizeIs   _) = True
+isSizeIs   _		    = False
+isLengthIs (Dep LengthIs _) = True
+isLengthIs _		    = False
+
+isMaxIs, isMinIs :: Dependent -> Bool
+isMinIs    (Dep MinIs _)    = True
+isMinIs    _		    = False
+isMaxIs    (Dep MaxIs _)    = True
+isMaxIs    _		    = False
+
+isFirstIs, isLastIs :: Dependent -> Bool
+isFirstIs  (Dep FirstIs _)  = True
+isFirstIs  _		    = False
+isLastIs   (Dep LastIs  _)  = True
+isLastIs   _		    = False
+
+sizeOrLength :: Dependent -> Bool
+sizeOrLength d = isSizeIs d || isLengthIs d
+
+minOrFirst :: Dependent -> Bool
+minOrFirst d = isMinIs d || isFirstIs d
+
+maxOrLast :: Dependent -> Bool
+maxOrLast d = isMaxIs d || isLastIs d
+
+isSwitchIs :: Dependent -> Bool
+isSwitchIs (Dep SwitchIs _) = True
+isSwitchIs _		    = False
+
+lookupDepender :: DependInfo -> Id -> Maybe [Dependent]
+lookupDepender ls i = 
+ case (filter (\ (i1, _) -> idName i1 == nm) ls) of
+   ((_,ls2):_) -> Just ls2
+   _	       -> Nothing
+ where
+  nm = idName i
+
+isDepender :: DependInfo -> Id -> Bool
+isDepender ls i = any isDependerElem ls
+  where
+   nm = idName i
+ 
+   isDependerElem (x,deps) = idName x == nm  && 
+			     notNull deps
+
+isSwitchDepender :: DependInfo -> Id -> Bool
+isSwitchDepender ls i = any isElem ls
+  where
+   nm = idName i
+ 
+   isElem (x,deps) = idName x == nm  && any (isSwitchIs) deps
+
+isDependee :: DependInfo -> Id -> Bool
+isDependee ls i = any (isDependeeElem nm) dvals
+ where
+   -- join up all the DepVals
+  dvals = concatMap ((concatMap (\ (Dep _ ls1) -> ls1)).snd) ls
+
+  nm  = idName i
+
+isDependeeElem :: String -> DepVal -> Bool
+isDependeeElem _  DepNone	     = False
+isDependeeElem _  (DepVal Nothing  _) = False
+isDependeeElem nm (DepVal (Just x) _) = x == nm
+
+isSwitchDependee :: DependInfo -> Id -> Bool
+isSwitchDependee lss i = any isSwitchDependeeElem ls
+ where
+  ls = concatMap (snd) lss
+
+  nm  = idName i
+
+  isSwitchDependeeElem (Dep SwitchIs ls1) = any (isDependeeElem nm) ls1
+  isSwitchDependeeElem _		  = False
+
+isNotSwitchDependee :: DependInfo -> Id -> Bool
+isNotSwitchDependee lss i = any isNotSwitchDependeeElem ls
+ where
+  ls = concatMap (snd) lss
+
+  nm  = idName i
+
+  isNotSwitchDependeeElem (Dep r ls1) | r /= SwitchIs = any (isDependeeElem nm) ls1
+  isNotSwitchDependeeElem _			      = False
+
+hasNonConstantExprs :: Dependent -> Bool
+hasNonConstantExprs (Dep _ ls) = any isNon ls
+  where
+   isNon (DepVal (Just _) _) = True
+   isNon _		     = False
+\end{code}
+
+Translating an IDL type name into a valid Haskell variable name.
+
+\begin{code}
+mkHaskellVarName :: Name -> Name
+mkHaskellVarName nm 
+  | optClassicNameMangling = toHask (casifyName nm)
+  | otherwise		   = toHask nm
+ where
+  toHask [] = "anon" -- shouldn't happen!
+--  toHask ('_':xs) = toHask xs -- drop leading underscores.
+  toHask (x:xs) | not (isAlpha x) = toHask xs  -- anything non-alphabetic, really.
+  toHask ls@(x:xs) 
+      | isUpper x = toLower x : map (subst '$' '_') xs
+      | otherwise = map (subst '$' '_') ls
+
+  subst x y ch | x == ch   = y
+	       | otherwise = ch
+
+\end{code}
+
+Translating an IDL type name into a valid Haskell type
+constructor name.
+
+\begin{code}
+mkHaskellTyConName :: Name -> Name
+mkHaskellTyConName nm 
+  | optClassicNameMangling = casifyName nm
+  | otherwise              = toHask nm
+ where
+  toHask [] = "Anon" -- shouldn't happen!
+  toHask (x:xs) | not (isAlpha x) = toHask xs  -- it's a non-starter with anything 
+					       -- non-alphabetic at the front (i.e.,
+					       -- don't want '_' there).
+  toHask ls@(x:xs) 
+        | isLower x = toUpper x : map (subst '$' '_') xs
+        | otherwise = map (subst '$' '_') ls
+
+  subst x y ch | x == ch   = y
+	       | otherwise = ch
+
+-- From: THIS_IS_A_SILLY_ID, ThisIs_ANOTHER_Silly_ID
+-- to: ThisIsASillyId, ThisIsAnotherSillyId
+casifyName :: String -> String
+casifyName nm = concatMap caseWord (split '_' nm)
+
+caseWord :: String -> String
+caseWord []     = []
+caseWord (c:cs) = toUpper c : cs'
+  where
+   cs'
+    | all (\ ch -> isUpper ch || isDigit ch) cs = map toLower cs
+    | otherwise      = cs
+
+\end{code}
+
+Until GHC supports the new FFI declarations, the IDL compiler will
+emit _casm_s that performs the actual invocation of COM methods.
+(but, more importantly, this is also used by the Hugs backend.)
+
+\begin{code}
+toCType :: Type -> Either String -- (primitive / FFI supported) C type
+			  String -- other; need C impedance matching code.
+toCType ty = 
+ case ty of
+   Char signed
+     | signed    -> Left "signed char"
+     | otherwise -> Left "unsigned char"
+   WChar -> Left "wchar_t"
+   Bool  -> Left "int" -- contentious
+   Octet    -> Left "unsigned char"
+   Integer LongLong signed
+     | signed     -> Left "int64"
+     | otherwise  -> Left "uint64"
+   Integer Natural True -> Left "int"
+   Integer sz signed
+     | signed    -> Left (sizeToString sz)
+     | otherwise -> Left ("unsigned " ++ sizeToString sz)
+   StablePtr -> Left "unsigned long"
+   Float sz -> 
+      case sz of
+       Short    -> Left "float"
+       Long     -> Left "double"
+       LongLong -> Left "long double"
+       Natural  -> Left "float"
+
+   String{}       -> Left "char*"
+   WString{}      -> Left "void*"
+   Sequence{}     -> Left "void*"
+   Enum{}         -> Left "int"
+
+   Struct _ [f] _ | isSimpleTy (fieldType f) -> toCType (fieldType f)
+   Struct i _ _    -> Right ("struct " ++ idName i)
+   Union i _ _ _ _ -> Right ("struct " ++ idName i) -- an encapsulated union is a struct in C.
+   UnionNon i _    ->  Right ("union "  ++ idName i)
+   CUnion i _ _    -> Right ("union " ++ idName i)
+
+   Name _ onm _ _ _  (Just ti) | not (is_pointed ti) -> Left (c_type ti)
+   			       | otherwise -> Right onm
+   Name _ onm _ _ Nothing  _   -> Right onm
+   Name _ onm _ _ (Just t) _  
+     | isConstructedTy t   -> if isEnumTy ty || isFunTy ty then toCType t else Right onm
+     | otherwise           -> toCType t
+   Pointer _ _ (Name _ _ _ (Just as) _ _)   -> 
+       case findAttribute "ctype" as of
+	 Just (Attribute _ [ParamLit (StringLit t)]) -> Left t
+         _ -> Left "void*"
+   Pointer _ _ (t@Iface{})   ->
+         case toCType t of
+	     Left l 
+	         -- confusingly, IA and IA* are the same thing when in 'C mode',
+		 -- so qualify the addition of an indirection accordingly.
+		 -- Ditto on the 'COM' side - if we end up with just 'IA' (which
+		 -- we shouldn't), treat this as IA*.
+		 -- 
+	             -> Left l
+	     Right x -> Right x
+   Pointer{}    -> Left "void*"
+   Array{}      -> Left "void*"
+   Void         -> Left "void"
+   SafeArray{}  -> Left "void*"
+   Iface _ _ _ as _ _ ->
+       case findAttribute "ctype" as of
+	 Just (Attribute _ [ParamLit (StringLit t)]) -> Left t
+         _ -> Left "void*"
+   FunTy{}      -> Left "void*"
+   Object	-> Left "void*"
+   Any		-> Left "void*"
+   _		-> error ("toCType: unhandled " ++ showCore (ppType ty))
+ where
+   sizeToString Short    = "short"
+   sizeToString Long     = "long"
+   sizeToString Natural  = "long"
+   sizeToString LongLong = "int64"
+\end{code}
+
+
+\begin{code}
+mkIfaceTypeName :: Name -> Name
+mkIfaceTypeName ('_':nm) = mkIfaceTypeName nm
+mkIfaceTypeName nm       = map (subst '$' '_') nm
+ where
+   subst x y ch | x == ch   = y
+		| otherwise = ch
+
+\end{code}
+
+From a set of parameter/result attributes, figure out the pointer
+type. Boolean flag determine whether the pointer is embedded or not.
+
+\begin{code}
+findPtrType :: Bool -> [Attribute] -> (Type -> Type) --PointerType
+findPtrType isTop ls =
+   -- a specific pointer type takes priority over
+   -- any setting of a pointer default.
+  case (filter isPtrAttr ptr_ls) of
+    ((Attribute kind []):_) -> Pointer (stringToPointerType kind) True
+    [] 
+     | isTop     -> Pointer Ref False
+     | otherwise -> 
+         case (filter isPtrDefault ptr_ls) of
+	    ((Attribute _ [ParamVar v]):_) -> Pointer (stringToPointerType v) False
+	    [] -> 
+		case optPointerDefault of
+		  Nothing -> Pointer Unique False
+		  Just x  -> Pointer (stringToPointerType x) False
+  where
+   ptr_ls = filter isPtrAttrib ls
+   
+   isPtrAttrib a = isPtrDefault a || isPtrAttr a
+ 
+   isPtrDefault (Attribute "pointer_default" [ParamVar _]) = True
+   isPtrDefault _ = False
+
+   isPtrAttr (Attribute "ptr" [])    = True
+   isPtrAttr (Attribute "ref" [])    = True
+   isPtrAttr (Attribute "unique" []) = True
+   isPtrAttr (Attribute "any" [])    = True
+   isPtrAttr _			     = False
+
+stringToPointerType :: String -> PointerType
+stringToPointerType "ref"     = Ref
+stringToPointerType "unique"  = Unique
+stringToPointerType "ptr"     = Ptr
+\end{code}
+
+\begin{code}
+idHaskellModule :: Id -> Maybe Name
+idHaskellModule i = mapMb (mkHaskellTyConName.dropSuffix) (idModule i)
+\end{code}
+
+
+Group the parameters according to their attributes
+(preserving the ordering of the given parameter list.)
+
+@binParams ls@ returns @(ps, is, os, ios, rs)@
+
+where
+
+<itemize>
+<item> @ps@ is the list of parameters the Haskell function takes
+   as arguments (this is not the final list, as the processing
+   of dependent arguments will remove the dependees.)
+<item> @is@ is the [in] parameters (preserved left-to-right ordering
+   of original parameter list.)
+<item> @os@ is the [out] params.
+<item> @ios@ is the [in,out] params.
+<item> @rs@ is the parameters that should be returned as results
+   from the Haskell programmer.
+</itemize>
+
+\begin{code}
+binParams :: [Param] -> ([Param], [Param], [Param], [Param], [Param])
+binParams ps = foldr binParam ([],[],[],[],[]) ps
+ where
+  binParam p (params, ins, outs, inouts, results) =
+      case (paramMode p) of
+        InOut ->
+	  case (paramType p) of
+	    Pointer Ptr _ _ -> (p:params, p:ins,outs, inouts, results)
+	    _		    -> (p:params, ins, outs, p:inouts, p:results)
+        In    -> (p:params, p:ins,outs, inouts, results)
+        Out   -> (params, ins, p:outs, inouts, p:results)
+\end{code}
+
+
+\begin{code}
+iPointerParam :: Name -> Param
+iPointerParam nm = 
+  mkParam "iptr" In
+          (Pointer Ptr True (Name (mkHaskellTyConName nm) nm Nothing Nothing Nothing Nothing))
+
+objParam :: Name -> Param
+objParam nm = 
+  mkParam "obj" In
+          (Name (mkHaskellTyConName nm) nm Nothing Nothing Nothing Nothing)
+
+resultParam :: Type -> Param
+resultParam ty = mkParam "result" Out ty
+\end{code}
+     
+Reduce fancy unions down to C-style unions and structs.
+
+\begin{code}
+unionToStruct :: Type -> (Maybe (Id, Type), Type)
+unionToStruct t =
+  case t of
+    UnionNon un_tag sws			  -> (Nothing, CUnion un_tag fields Nothing)
+	 where
+	  fields = map switchToField sws
+    Union enc_struct_tag tag_ty tg un_tag sws -> 
+	( Just (un_tag{idName=un_ty_nm, idOrigName=un_ty_nm}, c_union)
+	, Struct enc_struct_tag
+	       [ Field un_tag nm_ty nm_ty Nothing Nothing
+	       , Field tg     tag_ty  tag_ty  Nothing Nothing
+	       ]
+ 	       Nothing
+	)
+        where
+	  un_ty_nm  = "__IHC__" ++ idOrigName un_tag
+	  nm_ty     = Name un_ty_nm un_ty_nm Nothing Nothing (Just c_union) Nothing
+	  c_union = CUnion un_tag fields Nothing
+	  fields  = map switchToField sws
+    _ -> (Nothing, t)
+ where
+  switchToField (Switch i _ ty o_ty) = Field i ty o_ty Nothing Nothing
+  switchToField _                    = error "switchToField"
+
+\end{code}
+
+Check whether an interface derives from IDispatch or not.
+
+\begin{code}
+derivesFromIDispatch :: CoClassDecl -> Bool
+derivesFromIDispatch (CoClassInterface _ mb_decl) = 
+  case mb_decl of
+    Nothing -> False -- worth a warning?
+    Just d  -> 
+      case d of
+        Interface{declId=i,declInherit=inherits} ->
+	   idOrigName i == "IDispatch" || 
+	   any (\ (x,_) -> qName x == "IDispatch") inherits
+	DispInterface{} -> True
+derivesFromIDispatch _  = True
+\end{code}
+
+\begin{code}
+toDispInterfaceMethod :: Decl -> Decl
+toDispInterfaceMethod (Method i cc _ ps off) =
+     case break ((\ x -> hasAttributeWithName x "retval").idAttributes.paramId) ps of
+       (bef,p:aft) -> 
+	  let
+	   ty   = removePtr (paramType p)
+	   o_ty = removePtr (paramOrigType p)
+	  in
+          Method i cc (Result ty o_ty) (bef++aft) off
+       _ -> Method i cc (Result voidTy voidTy) ps off
+   
+toDispInterfaceMethod d = d
+
+\end{code}
+
+
+Order-sort declarations - by now, there should be no cyclic dependencies..
+
+\begin{code}
+sortDecls :: [Decl] -> [Decl]
+sortDecls ds = ds_sorted
+  where
+     -- compute def & use of the individual decls.
+   ds_depped  = map mkDeclDep ds
+
+     -- compute scc's
+   ds_groups  = stronglyConnComp ds_depped
+   
+     -- expand the cyclic groups
+   ds_sorted  = concatMap expandGroup ds_groups
+
+
+mkDeclDep :: Decl -> (Decl, String, [String])
+mkDeclDep d = let (def,uses) = getDeclUses d in (d,def,uses)
+
+getDeclUses :: Decl -> (String,[String])
+getDeclUses d = (def, uses)
+  where
+   uses = getUses d
+   def  = getDef d
+
+   getDef defn =
+    case defn of
+      Typedef i _ _         -> idName i
+      Constant i _ _ _      -> idName i
+      Interface i _ _ _     -> idName i
+      DispInterface i _ _ _ -> idName i
+      CoClass i _           -> idName i
+      Library i _           -> idName i
+      Method i _ _ _ _      -> idName i
+      Property i _ _ _ _    -> idName i
+      _			    -> ""
+
+getUses :: Decl -> [String]
+getUses d = 
+  case d of 
+    Typedef _ ty _	    -> getTyUses ty
+    Constant _ ty _ _       -> getTyUses ty
+    Interface _ _ is ds	    -> map (qName.fst) is ++ concatMap getUses ds
+    Module _ ds	            -> concatMap getUses ds
+    DispInterface _ _ ps ds -> concatMap getUses ps ++ concatMap getUses ds
+    CoClass _ cs	    -> map (idName.coClassId) cs
+    Library _ ds	    -> concatMap getUses ds
+    Method _ _ r ps _       -> getTyUses (resultType r) ++ concatMap (getTyUses.paramType) ps
+    Property _ t _ _ _      -> getTyUses t
+    _			    -> []
+
+-- Since the types were constructed from type libraries, we can make
+-- a number of simplifying assumptions.
+getTyUses :: Type -> [String]
+getTyUses ty =
+  case ty of
+    FunTy _ r ps    -> getTyUses (resultType r) ++ concatMap (getTyUses.paramType) ps
+    String t _ _    -> getTyUses t
+    Sequence t _ _  -> getTyUses t
+    Name  n _ _ _ _ _ -> [n]
+    Struct _ fs _   -> concatMap (getTyUses.fieldType)  fs
+    Union _ _ _ _ ss -> concatMap (getTyUses.switchType) ss
+    UnionNon _ ss   -> concatMap (getTyUses.switchType) ss
+    CUnion _ fs _   -> concatMap (getTyUses.fieldType)  fs
+    Pointer _ _ t   -> getTyUses t
+    Array t _       -> getTyUses t
+    Iface n _ _ _ _ _ -> [n]
+    SafeArray t       -> getTyUses t
+    _		      -> []
+
+expandGroup :: SCC a -> [a]
+expandGroup (AcyclicSCC d) = [d]
+expandGroup (CyclicSCC ds) = ds -- for now..
+
+\end{code}
+
+\begin{code}
+
+sizeofType :: Type -> Int
+sizeofType t = fst (sizeAndAlignModulus Nothing t)
+
+--tedious function that maps a type to its size and alignment modulus.
+--The constants it returns are platform dependent.
+sizeAndAlignModulus :: Maybe Int -> Type -> (Int, Int)
+sizeAndAlignModulus mb_pack ty =
+  case ty of
+    Float sz ->
+       case sz of
+         Short    -> (fLOAT_SIZE,  fLOAT_ALIGN_MODULUS)
+	 Long     -> (dOUBLE_SIZE, dOUBLE_ALIGN_MODULUS)
+	 LongLong -> (dOUBLE_SIZE, dOUBLE_ALIGN_MODULUS) -- no support for (long double)/quads yet (TODO)
+	 Natural  -> (dOUBLE_SIZE, dOUBLE_ALIGN_MODULUS)
+    Integer sz signed
+       | signed -> 
+         case sz of
+           Short     -> (sHORT_SIZE,    sHORT_ALIGN_MODULUS)
+           Long      -> (lONG_SIZE,     lONG_ALIGN_MODULUS)
+           Natural   -> (lONG_SIZE,     lONG_ALIGN_MODULUS)
+	   LongLong  -> (lONGLONG_SIZE, lONGLONG_ALIGN_MODULUS)
+       | otherwise ->
+         case sz of
+           Short     -> (uSHORT_SIZE,    uSHORT_ALIGN_MODULUS)
+           Long      -> (uLONG_SIZE,     uLONG_ALIGN_MODULUS)
+           Natural   -> (uLONG_SIZE,     uLONG_ALIGN_MODULUS)
+	   LongLong  -> (uLONGLONG_SIZE, uLONGLONG_ALIGN_MODULUS)
+    Char signed
+       | signed	      -> (sCHAR_SIZE, sCHAR_ALIGN_MODULUS)
+       | otherwise    -> (uCHAR_SIZE, uCHAR_ALIGN_MODULUS)
+    WChar	      -> (uCHAR_SIZE, uCHAR_ALIGN_MODULUS)
+    Bool	      -> (uLONG_SIZE, uLONG_ALIGN_MODULUS)
+    Octet	      -> (uCHAR_SIZE, uCHAR_ALIGN_MODULUS)
+    String{}	      -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS)
+    WString{}	      -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS)
+    Struct _ fields mb_pack2 -> (real_sz, real_ale)
+          where
+	    mb_pack_to_use = combinePackLevels mb_pack mb_pack2
+            (sz, al) = fst (computeStructSizeOffsets mb_pack_to_use fields)
+            real_ale = realModulus mb_pack_to_use al
+            real_sz  = align sz real_ale
+
+    Enum{}	       -> (lONG_SIZE, lONG_ALIGN_MODULUS) -- TODO: this is [v1_enum]
+    Union _ tty _ _ sw -> (align (uni_off + uni_sz) uni_align, uni_align)
+	    where
+	     sw_no_empties	       = filter (not.isEmptySwitch) sw
+	     
+	     isEmptySwitch (SwitchEmpty _) = True
+	     isEmptySwitch _		   = False
+
+	     (sw_sizes, sw_aligns)     = unzip (map ((sizeAndAlignModulus mb_pack).switchType) sw_no_empties)
+	     (tag_sz, {-tag_align-} _) = sizeAndAlignModulus mb_pack tty
+	     uni_sz     = maximum sw_sizes
+	     uni_align  = realModulus mb_pack (maximum sw_aligns)
+
+	      -- compute the offset of union (=> size of tag + pad.)
+             uni_off    = align tag_sz uni_align
+
+    UnionNon _ sw    -> (uni_sz, uni_align) 
+	    where
+	     sw_no_empties	   = filter (not.isEmptySwitch) sw
+
+	     isEmptySwitch (SwitchEmpty _) = True
+	     isEmptySwitch _		   = False
+
+	     (sw_sizes, sw_aligns) = unzip (map ((sizeAndAlignModulus mb_pack).switchType) sw_no_empties)
+	     uni_sz     = maximum sw_sizes
+	     uni_align  = realModulus mb_pack (maximum sw_aligns)
+
+    CUnion _ fields mb_pack2 -> (uni_sz, uni_align)
+	    where
+   	     mb_pack_to_use = combinePackLevels mb_pack mb_pack2
+
+	     (sw_sizes, sw_aligns) = 
+	     	unzip (map ((sizeAndAlignModulus mb_pack_to_use).fieldType) fields)
+	     uni_sz     = maximum sw_sizes
+	     uni_align  = realModulus mb_pack_to_use (maximum sw_aligns)
+
+    Pointer{}	     -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS)
+    Object	     -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS)
+    Any		     -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS)
+    FunTy{}          -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS)
+    Array aty [e]    -> let (el_sz, al) = sizeAndAlignModulus mb_pack aty in
+			(el_sz * fromIntegral (evalExpr e), al)
+     -- catch the case of conformant/open arrays.
+    Array aty []     -> let (el_sz, al) = sizeAndAlignModulus mb_pack aty in
+			(el_sz, al)
+    Array _ _	     -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS)
+    Void	     -> (0, dATA_PTR_ALIGN_MODULUS)
+    SafeArray{}	     -> (sAFEARRAY_SIZE, sAFEARRAY_ALIGN_MODULUS)
+    Name _ _ _ _ _ (Just ti) -> (prim_sizeof ti, prim_align ti)
+     -- need next one for when we're not doing magic overloading of variants.
+    Name "VARIANT" _ _ _ _ _ -> (16, 8) -- Vanilla fudge.
+--    Name "GUID" _ _ _ _ _    -> (16, 4) -- Vanilla fudge.
+    Name _ _ _ _ (Just t) _  -> sizeAndAlignModulus mb_pack t
+    Name nm _ _ _ Nothing _  -> let msg = error ("sizeAndAlignModulus: "++nm) in (msg, msg)
+    Fixed{}	      -> (undefined, undefined)
+    Sequence{}        -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS)
+    Any		      -> (undefined, undefined)
+    Object	      -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS)
+    Iface{}           -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS)
+    StablePtr{}       -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS)
+
+\end{code}
+
+\begin{code}
+computeStructSizeOffsets :: Maybe Int -> [Field] -> ((Int, Int), [Int])
+computeStructSizeOffsets mb_pack fields =
+ case (mapAccumL (place mb_pack) (0::Int,1::Int) fields) of
+   ((size, al), offsets) ->
+     let real_al = max structAlign al in
+     ( (align size real_al, real_al)
+     , offsets
+     )
+ where
+  structAlign = sTRUCT_ALIGN_MODULUS
+
+place :: Maybe Int
+      -> ( Int       -- tentative offset for field 
+	 , Int       -- current alignment modulus for struct
+	 )  
+      -> Field
+      -> ( (Int,Int) -- updated state
+	 , Int       -- offset at which to store/access field.
+	 )
+place mb_pack (off,struct_align) f =
+ case sizeAndAlignModulus mb_pack (fieldType f) of
+   (sz, al) -> 
+        let 
+	 real_ale  = realModulus mb_pack al
+         field_off = align off real_ale
+	in
+	((field_off+sz, max real_ale struct_align), field_off)
+
+realModulus :: Maybe Int -> Int -> Int
+realModulus Nothing  n = n
+realModulus (Just v) n = min v n
+
+-- align off al = off' such that (off' `mod` align = 0)
+align :: Int -> Int -> Int
+align off al 
+ | off `mod` al == 0 = off -- perfect, no padding.
+ | otherwise	     = off + (al - off `mod` al)
+
+combinePackLevels :: Maybe Int -> Maybe Int -> Maybe Int
+combinePackLevels Nothing x = x
+combinePackLevels x       Nothing = x
+combinePackLevels (Just _) (Just y) = Just y -- the inner one 'wins'.
+\end{code}
+
+When deciding whether to generate (or use) a marshaller for a 
+type, we need to know whether it is (or has components) that are
+finalised. The reason we need to know this detail of the type is
+that finalisation is handled differently depending on whether the
+unmarshaller is called from a stub or a proxy.
+
+\begin{code}
+isFinalisedType :: Bool -> Type -> Bool
+isFinalisedType ifaceOnly t =
+  case t of
+    Integer{}   -> False
+    StablePtr{} -> False
+    Float{}     -> False
+    Char{}    -> False
+    WChar{}   -> False
+    FunTy _ r ps -> any (isFinalisedType ifaceOnly) (resultType r : map paramType ps)
+    Bool{}    -> False
+    Octet{}   -> False
+    Any{}     -> False
+    Object{}  -> False
+    String{}  -> False
+    WString{} -> False
+    Sequence ty _ _ -> isFinalisedType ifaceOnly ty
+    Fixed{}   -> False
+    Void{}    -> False
+    SafeArray _ -> True
+    Iface _ _ _ as _ _   -> not optHaskellToC || as `hasAttributeWithName` "finaliser"
+    Array ty   _ -> isFinalisedType ifaceOnly ty
+    Pointer Ptr _ _ -> False
+    Pointer _ _ ty  -> isFinalisedType ifaceOnly ty
+    Struct _ fs _ -> any (isFinalisedType ifaceOnly) (map fieldType fs)
+    CUnion _ fs _ -> any (isFinalisedType ifaceOnly) (map fieldType fs)
+    UnionNon _ ss -> any (isFinalisedType ifaceOnly) (map switchType (filter isNonDef ss))
+    Enum{}    -> False
+    Union _ _ _ _ ss -> any (isFinalisedType ifaceOnly) (map switchType (filter isNonDef ss))
+    Name _ _ _ _ _ (Just ti) -> not ifaceOnly && finalised ti
+    Name _ _ _ _ (Just ty) _ -> isFinalisedType ifaceOnly ty
+    Name{}	-> False
+ where
+  isNonDef Switch{} = True
+  isNonDef _	    = False
+
+\end{code}
+ src/CustomAttributes.hs view
@@ -0,0 +1,91 @@+--
+-- (c) 2001, sof
+--
+module CustomAttributes where
+
+import BasicTypes ( Name )
+{- This module serves to collect together and document the attribute
+   extensions that HDirect makes to (DCE) IDL. At the moment, mostly
+   the former!
+-}
+sequenceAttr   :: Name
+sequenceAttr   = "sequence"
+
+terminatorAttr :: Name
+terminatorAttr = "terminator"
+
+ignoreAttr     :: Name
+ignoreAttr     = "ignore"
+
+newtypeAttr    :: Name
+newtypeAttr    = "hs_newtype"
+
+pureAttr       :: Name
+pureAttr       = "pure"
+
+flagAttr       :: Name
+flagAttr       = "hs_flag"
+
+finaliserAttr  :: Name
+finaliserAttr  = "finaliser"
+
+abstractAttr   :: Name
+abstractAttr   = "abstract"
+
+foreignAttr    :: Name
+foreignAttr    = "foreign"
+
+tyArgAttr      :: Name
+tyArgAttr      = "hs_tyarg"
+
+ignoreResAttr  :: Name
+ignoreResAttr  = "hs_ignore_result"
+
+noFreeAttr     :: Name
+noFreeAttr     = "nofree"
+
+freeAttr       :: Name
+freeAttr       = "free"
+
+freeMethodAttr :: Name
+freeMethodAttr = "free_method"
+
+errorHandlerAttr :: Name
+errorHandlerAttr = "error_handler"
+
+cconvAttr      :: Name
+cconvAttr      = "cconv"
+
+derivingAttr   :: Name
+derivingAttr   = "deriving"
+
+tyArgsAttr     :: Name
+tyArgsAttr     = "ty_args"
+
+ctypeAttr      :: Name
+ctypeAttr      = "ctype"
+
+hsNameAttr     :: Name
+hsNameAttr     = "hs_name"
+
+tyParamsAttr   :: Name
+tyParamsAttr   = "ty_params"
+
+dllNameAttr    :: Name
+dllNameAttr    = "dllname"
+
+jniImplementsAttr,jniClassAttr :: Name
+jniImplementsAttr = "jni_implements"
+jniClassAttr      = "jni_class"
+
+jniGetFieldAttr, jniSetFieldAttr :: Name
+jniGetFieldAttr   = "jni_get_field"
+jniSetFieldAttr   = "jni_set_field"
+
+jniStaticAttr, jniIfaceTyAttr :: Name
+jniStaticAttr     = "jni_static"
+jniIfaceTyAttr    = "jni_iface_ty"
+
+jniFinalAttr, jniCtorAttr :: Name
+jniFinalAttr      = "jni_final"
+jniCtorAttr       = "jni_ctor"
+ src/DefGen.lhs view
@@ -0,0 +1,48 @@+%
+%
+%
+
+Generate module definition files (Win32 specific).
+
+\begin{code}
+module DefGen (defGen) where
+
+import List
+import AbstractH
+import Utils
+\end{code}
+
+\begin{code}
+defGen :: [(String, Bool, [HTopDecl])] -> [(String,String)]
+defGen code = 
+   map genDef $ 
+   groupBy eqMod $
+   sortBy cmpMod (foldr getLocSpecs [] (map (\ (_,_,x) -> getDecl x) code))
+  where
+   eqMod  (x,_,_,_) (y,_,_,_)  = x == y
+   cmpMod (x,_,_,_) (y,_,_,_) = compare x y
+
+   getDecl [] = error "defGen.getDecls: not supposed to happen!"
+   getDecl ((HMod (HModule _ _ _ _ h)):_) = h
+   getDecl (_:hs) = getDecl hs
+
+   getLocSpecs (AndDecl h1 h2) acc = getLocSpecs h1 (getLocSpecs h2 acc)
+   getLocSpecs (Primitive _ _ ls _ _ _ _ _) acc = ls:acc
+   getLocSpecs _ acc = acc
+
+   genDef ls = (defName ls, defExports ls)
+
+   defName [] = "Anon"
+   defName ((l,_,_,_):_) = (dropSuffix l) ++ ".def"
+
+   defExports ls = unlines ("EXPORTS" : nub (map genExp ls))
+      
+   genExp (_,Nothing,nm,_)  = nm
+   genExp (_,Just x,nm,dec) = nm' ++ ' ':'@':show x
+	where
+	 nm' =
+	   case dec of
+	     Nothing -> nm
+	     Just i  -> nm ++ '@':show i
+
+\end{code}
+ src/Desugar.lhs view
@@ -0,0 +1,2083 @@+%
+% (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<X>" 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}
+ src/Digraph.lhs view
@@ -0,0 +1,396 @@+\begin{code}
+module Digraph(
+
+	-- At present the only one with a "nice" external interface
+	stronglyConnComp, stronglyConnCompR, SCC(..),
+
+	Graph, Vertex, 
+	graphFromEdges, buildG, transposeG, reverseE, outdegree, indegree,
+
+	Tree(..), Forest,
+	showTree, showForest,
+
+	dfs, dff,
+	topSort,
+	components,
+	scc,
+	back, cross, forward,
+	reachable, path,
+	bcc
+
+    ) where
+
+------------------------------------------------------------------------------
+-- A version of the graph algorithms described in:
+-- 
+-- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell''
+--   by David King and John Launchbury
+-- 
+-- Also included is some additional code for printing tree structures ...
+------------------------------------------------------------------------------
+
+-- GHC extensions
+import Control.Monad.ST
+import Data.Array.ST
+import GHC.Arr
+
+-- std interfaces
+import Maybe
+import Array
+import List ( sortBy, (\\) )
+\end{code}
+
+
+%************************************************************************
+%*									*
+%*	External interface
+%*									*
+%************************************************************************
+
+\begin{code}
+data SCC vertex = AcyclicSCC vertex
+	        | CyclicSCC  [vertex]
+
+stronglyConnComp
+	:: Ord key
+	=> [(node, key, [key])]		-- The graph; its ok for the
+					-- out-list to contain keys which arent
+					-- a vertex key, they are ignored
+	-> [SCC node]
+
+stronglyConnComp es
+  = map get_node (stronglyConnCompR es)
+  where
+    get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
+    get_node (CyclicSCC triples)     = CyclicSCC [n | (n,_,_) <- triples]
+
+-- The "R" interface is used when you expect to apply SCC to
+-- the (some of) the result of SCC, so you dont want to lose the dependency info
+stronglyConnCompR
+	:: Ord key
+	=> [(node, key, [key])]		-- The graph; its ok for the
+					-- out-list to contain keys which arent
+					-- a vertex key, they are ignored
+	-> [SCC (node, key, [key])]
+
+stronglyConnCompR [] = []  -- added to avoid creating empty array in graphFromEdges -- SOF
+stronglyConnCompR es
+  = map decode forest
+  where
+    (graph, vertex_fn) = graphFromEdges es
+    forest	       = scc graph
+    decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
+		       | otherwise	   = AcyclicSCC (vertex_fn v)
+    decode other = CyclicSCC (dec other [])
+		 where
+		   dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
+    mentions_itself v = v `elem` (graph ! v)
+\end{code}
+
+%************************************************************************
+%*									*
+%*	Graphs
+%*									*
+%************************************************************************
+
+
+\begin{code}
+type Vertex  = Int
+type Table a = Array Vertex a
+type Graph   = Table [Vertex]
+type Bounds  = (Vertex, Vertex)
+type Edge    = (Vertex, Vertex)
+\end{code}
+
+\begin{code}
+vertices :: Graph -> [Vertex]
+vertices  = indices
+
+edges    :: Graph -> [Edge]
+edges g   = [ (v, w) | v <- vertices g, w <- g!v ]
+
+mapT    :: (Vertex -> a -> b) -> Table a -> Table b
+mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
+
+buildG :: Bounds -> [Edge] -> Graph
+buildG bnds es = accumArray (flip (:)) [] bnds [(,) k v | (k,v) <- es]
+
+transposeG  :: Graph -> Graph
+transposeG g = buildG (bounds g) (reverseE g)
+
+reverseE    :: Graph -> [Edge]
+reverseE g   = [ (w, v) | (v, w) <- edges g ]
+
+outdegree :: Graph -> Table Int
+outdegree  = mapT numEdges
+             where numEdges _ ws = length ws
+
+indegree :: Graph -> Table Int
+indegree  = outdegree . transposeG
+\end{code}
+
+
+\begin{code}
+graphFromEdges
+	:: Ord key
+	=> [(node, key, [key])]
+	-> (Graph, Vertex -> (node, key, [key]))
+graphFromEdges es
+  = (graph, \v -> vertex_map ! v)
+  where
+    max_v      	    = length es - 1
+    bnds            = (0,max_v) :: (Vertex, Vertex)
+    sorted_edges    = sortBy lt es
+    edges1	    = zipWith (,) [0..] sorted_edges
+
+    graph	    = array bnds [(,) v (mapMaybe key_vertex ks) | (,) v (_,    _, ks) <- edges1]
+    key_map	    = array bnds [(,) v k			       | (,) v (_,    k, _ ) <- edges1]
+    vertex_map	    = array bnds edges1
+
+    (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 --of { LT -> True; other -> False }
+
+    -- key_vertex :: key -> Maybe Vertex
+    -- 	returns Nothing for non-interesting vertices
+    key_vertex k   = find 0 max_v 
+		   where
+		     find a b | a > b 
+			      = Nothing
+		     find a b = case compare k (key_map ! mid) of
+				   LT -> find a (mid-1)
+				   EQ -> Just mid
+				   GT -> find (mid+1) b
+			      where
+			 	mid = (a + b) `div` 2
+\end{code}
+
+%************************************************************************
+%*									*
+%*	Trees and forests
+%*									*
+%************************************************************************
+
+\begin{code}
+data Tree a   = Node a (Forest a)
+type Forest a = [Tree a]
+
+mapTree              :: (a -> b) -> (Tree a -> Tree b)
+mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
+\end{code}
+
+\begin{code}
+instance Show a => Show (Tree a) where
+  showsPrec _ t s = showTree t ++ s
+
+showTree :: Show a => Tree a -> String
+showTree  = drawTree . mapTree show
+
+showForest :: Show a => Forest a -> String
+showForest  = unlines . map showTree
+
+drawTree        :: Tree String -> String
+drawTree         = unlines . draw
+
+draw :: Tree String -> [String]
+draw (Node x xs) = grp this (space (length this)) (stLoop xs)
+ where this          = s1 ++ x ++ " "
+
+       space n       = take n (repeat ' ')
+
+       stLoop []     = [""]
+       stLoop [t]    = grp s2 "  " (draw t)
+       stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
+
+       rsLoop []     = []
+       rsLoop [t]    = grp s5 "  " (draw t)
+       rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
+
+       grp first rst = zipWith (++) (first:repeat rst)
+
+       [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
+\end{code}
+
+
+%************************************************************************
+%*									*
+%*	Depth first search
+%*									*
+%************************************************************************
+
+\begin{code}
+type Set s    = STArray s Vertex Bool
+
+mkEmpty      :: Bounds -> ST s (Set s)
+mkEmpty bnds  = newSTArray bnds False
+
+contains     :: Set s -> Vertex -> ST s Bool
+contains m v  = readSTArray m v
+
+include      :: Set s -> Vertex -> ST s ()
+include m v   = writeSTArray m v True
+\end{code}
+
+\begin{code}
+dff          :: Graph -> Forest Vertex
+dff g         = dfs g (vertices g)
+
+dfs          :: Graph -> [Vertex] -> Forest Vertex
+dfs g vs      = prune (bounds g) (map (generate g) vs)
+
+generate     :: Graph -> Vertex -> Tree Vertex
+generate g v  = Node v (map (generate g) (g!v))
+
+prune        :: Bounds -> Forest Vertex -> Forest Vertex
+prune bnds ts = runST (mkEmpty bnds  >>= \m ->
+                       chop m ts)
+
+chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)
+chop _ []     = return []
+chop m (Node v ts : us)
+              = contains m v >>= \visited ->
+                if visited then
+                  chop m us
+                else
+                  include m v >>= \_  ->
+                  chop m ts   >>= \as ->
+                  chop m us   >>= \bs ->
+                  return (Node v as : bs)
+\end{code}
+
+
+%************************************************************************
+%*									*
+%*	Algorithms
+%*									*
+%************************************************************************
+
+------------------------------------------------------------
+-- Algorithm 1: depth first search numbering
+------------------------------------------------------------
+
+\begin{code}
+preorder            :: Tree a -> [a]
+preorder (Node a ts) = a : preorderF ts
+
+preorderF           :: Forest a -> [a]
+preorderF ts         = concat (map preorder ts)
+
+{- UNUSED:
+preOrd :: Graph -> [Vertex]
+preOrd  = preorderF . dff
+-}
+
+tabulate        :: Bounds -> [Vertex] -> Table Int
+tabulate bnds vs = array bnds (zipWith (,) vs [1..])
+
+preArr          :: Bounds -> Forest Vertex -> Table Int
+preArr bnds      = tabulate bnds . preorderF
+\end{code}
+
+
+------------------------------------------------------------
+-- Algorithm 2: topological sorting
+------------------------------------------------------------
+
+\begin{code}
+postorder :: Tree a -> [a]
+postorder (Node a ts) = postorderF ts ++ [a]
+
+postorderF   :: Forest a -> [a]
+postorderF ts = concat (map postorder ts)
+
+postOrd      :: Graph -> [Vertex]
+postOrd       = postorderF . dff
+
+topSort      :: Graph -> [Vertex]
+topSort       = reverse . postOrd
+\end{code}
+
+
+------------------------------------------------------------
+-- Algorithm 3: connected components
+------------------------------------------------------------
+
+\begin{code}
+components   :: Graph -> Forest Vertex
+components    = dff . undirected
+
+undirected   :: Graph -> Graph
+undirected g  = buildG (bounds g) (edges g ++ reverseE g)
+\end{code}
+
+
+-- Algorithm 4: strongly connected components
+
+\begin{code}
+scc  :: Graph -> Forest Vertex
+scc g = dfs g (reverse (postOrd (transposeG g)))
+\end{code}
+
+
+------------------------------------------------------------
+-- Algorithm 5: Classifying edges
+------------------------------------------------------------
+
+\begin{code}
+{- UNUSED
+tree              :: Bounds -> Forest Vertex -> Graph
+tree bnds ts       = buildG bnds (concat (map flat ts))
+		   where
+		     flat (Node v rs) = [ (v, w) | Node w us <- ts ] ++
+                    		        concat (map flat ts)
+-}
+back              :: Graph -> Table Int -> Graph
+back g post        = mapT select g
+ where select v ws = [ w | w <- ws, post!v < post!w ]
+
+cross             :: Graph -> Table Int -> Table Int -> Graph
+cross g pre post   = mapT select g
+ where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
+
+forward           :: Graph -> Graph -> Table Int -> Graph
+forward g tree pre = mapT select g
+ where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
+\end{code}
+
+
+------------------------------------------------------------
+-- Algorithm 6: Finding reachable vertices
+------------------------------------------------------------
+
+\begin{code}
+reachable    :: Graph -> Vertex -> [Vertex]
+reachable g v = preorderF (dfs g [v])
+
+path         :: Graph -> Vertex -> Vertex -> Bool
+path g v w    = w `elem` (reachable g v)
+\end{code}
+
+
+------------------------------------------------------------
+-- Algorithm 7: Biconnected components
+------------------------------------------------------------
+
+\begin{code}
+bcc :: Graph -> Forest [Vertex]
+bcc g = (concat . map bicomps . map (label g dnum)) forest
+ where forest = dff g
+       dnum   = preArr (bounds g) forest
+
+label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
+label g dnum (Node v ts) = Node (v,dnum!v,lv) us
+ where us = map (label g dnum) ts
+       lv = minimum ([dnum!v] ++ [dnum!w | w  <- g!v]
+                     ++ [lu | Node (_,_,lu) _ <- us])
+
+bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
+bicomps (Node (v,_,_) ts)
+      = [ Node (v:vs) us | (_,Node vs us) <- map collect ts]
+
+collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
+collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
+ where collected = map collect ts
+       vs = concat [ ws | (lw, Node ws _)  <- collected, lw<dv]
+       cs = concat [ if lw<dv then us else [Node (v:ws) us]
+                        | (lw, Node ws us) <- collected ]
+\end{code}
+
+ src/DsMonad.lhs view
@@ -0,0 +1,452 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 9th 2003  15:08  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+The desugar monad helps carry around environments
+that maps user defined type names to their type and
+attributes.
+
+\begin{code}
+module DsMonad 
+	(
+	  DsM
+	, runDsM 		-- :: String 
+				-- -> Env String TypeInfo
+				-- -> Env String (Bool, [IDL.Attribute])
+				-- -> String DsM a
+				-- -> IO a
+
+	, mapDsM		-- :: (a -> b) -> DsM a -> DsM b
+
+	, lookupType		-- :: String -> DsM (Maybe (String,Type, [Attribute]))
+	, lookupTypeInfo	-- :: String -> DsM (Maybe TypeInfo)
+	, lookupAsf             -- :: String -> DsM (Maybe (Bool,[IDL.Attribute]))
+	, lookupConst		-- :: String -> DsM (Maybe Int32)
+	, lookupIface		-- :: String -> DsM (Maybe Decl)
+	, lookupTag		-- :: String -> DsM (Maybe (String, String))
+
+	, getAttributes	        -- :: DsM [Attribute]
+	, propagateAttributes   -- :: [Attribute] -> DsM a -> DsM a
+	, withAttributes        -- :: [Attribute] -> DsM a -> DsM a
+	
+	, getSrcFilename        -- :: DsM String
+
+	, pushPack		-- :: Maybe (Maybe (String, Maybe Int)) -> DsM ()
+	, popPack               -- :: Maybe (String, Maybe Int) -> DsM ()
+	, getCurrentPack        -- :: DsM (Maybe Int)
+
+	, openUpScope		-- :: DsM a -> DsM a
+
+	, addToTypeEnv		-- :: String -> (Type, [Attribute]) -> DsM ()
+	, addToIfaceEnv		-- :: String -> Decl   -> DsM ()
+	, addToConstEnv		-- :: String -> Int32  -> DsM ()
+	, getConstEnv           -- :: DsM ConstEnv
+	, addToTagEnv		-- :: String -> String -> DsM ()
+	, addSourceIface        -- :: String -> DsM ()
+
+	, getFilename		-- :: DsM (Maybe String)
+	, setFilename		-- :: Maybe String -> DsM ()
+	
+	, getInterface	        -- :: DsM (Maybe String)
+	, withInterface         -- :: String -> DsM a -> DsM a
+	
+	, addToPath             -- :: String -> DsM a -> DsM a
+	, getPath               -- :: DsM String
+	
+	, inLibrary             -- :: DsM a -> DsM a
+	, isInLibrary           -- :: DsM Bool
+	
+	, inImportedContext     -- :: DsM a -> DsM a
+	, isInImportedContext   -- :: DsM Bool
+	
+	, addWarning		-- :: String -> DsM ()
+	
+	, ioToDsM		-- :: IO a -> DsM a
+	
+	, TypeEnv
+	, SourceEnv
+	, ConstEnv
+	, TagEnv
+	, IfaceEnv
+	, TypeInfo
+
+	) where
+
+import CoreIDL
+import qualified IDLSyn as IDL ( Attribute )
+import CoreUtils ( childAttributes )
+import Env
+import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
+import IO  ( hPutStrLn, stderr )
+import Int ( Int32 )
+import Monad ( when )
+import Opts  ( optVerbose, optDebug )
+import Maybe ( catMaybes )
+import TypeInfo
+
+\end{code}
+
+Lots of stuff being plumbed here...maybe I qualify for a plumber's
+diploma on the grounds of this monad? 
+
+\begin{code}
+type TypeEnv      = Env String (Maybe String, Type, [Attribute])
+type IfaceEnv     = Env String Decl{-Decl.{Disp}Interface constructor only-}
+type ConstEnv     = Env String (Either Int32 Expr)
+type SourceEnv    = Env String ()
+type TagEnv       = Env String (Maybe String, String) {- struct/union/enum tag to name of typedef -}
+
+data EnvChain
+ = EnvChain
+      TypeEnv  -- default/builtins
+      [DsEnvs]
+
+data DsEnvs
+ = DsEnvs 
+     { type_env :: TypeEnv
+     , if_env   :: IfaceEnv
+     , co_env   :: ConstEnv
+     , tg_env   :: TagEnv
+     , src_env  :: SourceEnv
+     }
+
+freshDsEnv :: DsEnvs
+freshDsEnv = DsEnvs newEnv newEnv newEnv newEnv newEnv
+
+-- As an experiment, this monad uses an environment containing 
+-- IORefs rather than thread the information they carry. It is
+-- questionable whether this is more efficient, and the result
+-- is less than pretty => switch to threading the info sometime
+-- in the future.
+
+
+data DsMEnv
+ = DsMEnv 
+    { env_ref    :: IORef EnvChain
+    , at_ref     :: (IORef [Attribute])    -- the current interface's attributes
+    , fn_ref     :: (IORef (Maybe String)) -- current file/module name
+    , current_if :: (IORef (Maybe String)) -- current (disp)interface
+    , in_lib     :: (IORef Bool)
+    , in_import  :: (IORef Bool)
+    , tinfo_env  :: Env String TypeInfo
+    , asf_env    :: Env String (Bool,[IDL.Attribute])
+    , pack_stk   :: IORef [(Maybe String, Int)]
+    , nm_path    :: String
+    , src_name   :: String
+    }
+
+newtype DsM a = DsM (DsMEnv -> IO a)
+\end{code}
+
+Types out of the way, here's the big ugly action for performing @DsM@
+actions:
+
+\begin{code}
+runDsM :: String
+       -> Env String TypeInfo
+       -> Env String (Bool,[IDL.Attribute])
+       -> [(String, Maybe String, Type)]
+       -> DsM a
+       -> IO (a, TypeEnv, TagEnv, SourceEnv, IfaceEnv)
+runDsM srcFileName tInfo aenv defs (DsM m) = do
+  at       <- newIORef []
+  pck      <- newIORef []
+  md       <- newIORef Nothing
+  cur_if   <- newIORef Nothing
+  in_l     <- newIORef False
+  in_im    <- newIORef False
+  let tenv = addListToEnv newEnv (map (\(n,mo,t) -> (n, (mo,t,[]))) defs)
+      cha  = EnvChain tenv [freshDsEnv]
+  chain    <- newIORef cha
+  let denv = DsMEnv chain at md cur_if in_l in_im tInfo
+  		    aenv pck "" srcFileName
+  a        <- m denv
+  cha1     <- readIORef chain      
+  let (EnvChain t ds) = cha1
+      ty = unionEnvs (t:map type_env ds)
+      ta = unionEnvs (map tg_env ds)
+      sr = unionEnvs (map src_env  ds)
+      ir = unionEnvs (map if_env ds)
+  return (a, ty, ta, sr, ir)
+
+thenDsM :: DsM a -> (a -> DsM b) -> DsM b
+thenDsM (DsM m) n =
+ DsM (\ te -> do
+       v <- m te
+       case n v of
+         DsM k -> k te)
+
+returnDsM :: a -> DsM a
+returnDsM v = DsM (\ _ -> return v)
+
+openUpScope :: DsM a -> DsM a
+openUpScope (DsM a) = liftDsM $ \ dse -> do
+	 let ref = env_ref dse
+         cha <- readIORef ref
+	 let (EnvChain t (x:ls)) = cha
+	 writeIORef ref (EnvChain t [freshDsEnv])
+	 v    <- a dse
+         cha1 <- readIORef ref
+	 let (EnvChain t1 nls) = cha1
+	     ls' = x:nls ++ ls
+	 writeIORef ref (EnvChain t1 ls')
+	 return v
+
+liftDsM :: (DsMEnv -> IO a) -> DsM a
+liftDsM a = DsM a
+
+lookupType :: String -> DsM (Maybe (Maybe String, Type, [Attribute]))
+lookupType str = liftDsM $ 
+   \ (DsMEnv{env_ref=ref}) -> do
+        chain <- readIORef ref
+	let (EnvChain t ds) = chain
+        case lookupEnv t str of
+	   x@(Just _) -> return x
+	   _ ->	case catMaybes (map (\ d -> lookupEnv (type_env d) str) ds) of
+		  []    -> return Nothing
+		  (x:_) -> return (Just x)
+
+lookupTypeInfo :: String -> DsM (Maybe TypeInfo)
+lookupTypeInfo str = liftDsM (\ (DsMEnv{tinfo_env=ti})  -> return (lookupEnv ti str))
+
+lookupAsf :: String -> DsM (Maybe (Bool, [IDL.Attribute]))
+lookupAsf str = liftDsM (\ (DsMEnv{asf_env=as})  -> return (lookupEnv as str))
+
+lookupConst :: String -> DsM (Maybe (Either Int32 Expr))
+lookupConst str = liftDsM $ 
+    \ (DsMEnv{env_ref=ref}) -> do
+        chain <- readIORef ref
+	let (EnvChain _ ls) = chain
+      	case catMaybes (map (\ d -> lookupEnv (co_env d) str) ls) of
+	   []    -> return Nothing
+	   (x:_) -> return (Just x)
+
+lookupIface :: String -> DsM (Maybe Decl)
+lookupIface str = liftDsM $ 
+   \ (DsMEnv{env_ref=ref}) -> do
+        chain <- readIORef ref
+	let (EnvChain _ ls) = chain
+      	case catMaybes (map (\ d -> lookupEnv (if_env d) str) ls) of
+	   []    -> return Nothing
+	   (x:_) -> return (Just x)
+
+lookupTag :: String -> DsM (Maybe (Maybe String, String))
+lookupTag str = liftDsM $ 
+   \ (DsMEnv{env_ref=ref}) -> do
+        chain <- readIORef ref
+	let (EnvChain _ ls) = chain
+      	case catMaybes (map (\ d -> lookupEnv (tg_env d) str) ls) of
+	   []    -> return Nothing
+	   (x:_) -> return (Just x)
+
+getAttributes :: DsM [Attribute]
+getAttributes = liftDsM (\ (DsMEnv{at_ref=at_v})  -> readIORef at_v)
+
+{- UNUSED
+getInheritedAttributes :: DsM [Attribute]
+getInheritedAttributes = 
+   liftDsM (\ (DsMEnv{at_ref=at_v})  -> do
+		ls <- readIORef at_v
+		return (childAttributes ls))
+-}
+
+getSrcFilename :: DsM String
+getSrcFilename = liftDsM (\ (DsMEnv{src_name=s})  -> return s)
+
+withAttributes :: [Attribute] -> DsM a -> DsM a
+withAttributes ats (DsM act) = liftDsM $
+   \ env@(DsMEnv{at_ref=at_v}) -> do
+	old_at <- readIORef at_v
+	writeIORef at_v ats
+	v      <- act env
+	writeIORef at_v old_at
+	return v
+
+-- like withAttributes, but filter out the non-inheritable ones.
+propagateAttributes :: [Attribute] -> DsM a -> DsM a
+propagateAttributes ats (DsM act) = liftDsM $
+   \ env@(DsMEnv{at_ref=at_v}) -> do
+	old_at <- readIORef at_v
+	writeIORef at_v (childAttributes ats)
+	v      <- act env
+	writeIORef at_v old_at
+	return v
+
+{-
+ An IDL specification may import a number of other specs. The meaning
+ of an import is simply to bring the definitions of types and interfaces
+ into scope, no code is generated for the imported entities (you'd
+ use #include to (optionally) do literal code inclusion.)
+
+ When desugaring, we work our way through the imports, stashing information
+ about types, constants and interfaces into appropriate environments.
+-}
+addToTypeEnv :: String -> Maybe String -> (Type, [Attribute]) -> DsM ()
+addToTypeEnv str md (ty,at) = liftDsM $
+    \ (DsMEnv{env_ref=ref}) -> do
+--        hPutStrLn stderr ("Adding: " ++ str)
+        chain <- readIORef ref
+	let (EnvChain t (d:ds)) = chain
+	    ty_env = type_env d
+	    d' =d{type_env=addToEnv ty_env str (md,ty,at)}
+	writeIORef ref (EnvChain t (d':ds))
+
+addToIfaceEnv :: String -> Decl -> DsM ()
+addToIfaceEnv str val = liftDsM $
+   \ (DsMEnv{env_ref=ref}) -> do
+        chain <- readIORef ref
+	let (EnvChain t (d:ds)) = chain
+	    ienv = if_env d
+	    d' =d{if_env=addToEnv ienv str val}
+	writeIORef ref (EnvChain t (d':ds))
+
+addSourceIface :: String -> DsM ()
+addSourceIface str = liftDsM $
+   \ (DsMEnv{env_ref=ref}) -> do
+        chain <- readIORef ref
+	let (EnvChain t (d:ds)) = chain
+	    senv = src_env d
+	    d' =d{src_env=addToEnv senv str ()}
+	writeIORef ref (EnvChain t (d':ds))
+
+addToConstEnv :: String -> Either Int32 Expr -> DsM ()
+addToConstEnv str val = liftDsM $
+    \ (DsMEnv{env_ref=ref}) -> do
+        chain <- readIORef ref
+	let (EnvChain t (d:ds)) = chain
+	    cenv = co_env d
+	    d' =d{co_env=addToEnv cenv str val}
+	writeIORef ref (EnvChain t (d':ds))
+
+addToTagEnv :: String -> String -> DsM ()
+addToTagEnv str val = liftDsM $ 
+  \ (DsMEnv{env_ref=ref,fn_ref=fe}) -> do
+        chain <- readIORef ref
+	md    <- readIORef fe
+	let (EnvChain t (d:ds)) = chain
+	    tenv = tg_env d
+	    d' =d{tg_env=addToEnv tenv str (md,val)}
+	writeIORef ref (EnvChain t (d':ds))
+
+getConstEnv :: DsM ConstEnv
+getConstEnv = liftDsM $
+  \ DsMEnv{env_ref=ref} -> do
+      chain <- readIORef ref
+      let (EnvChain _ ds) = chain
+      return (unionEnvs (map co_env ds))
+
+getFilename :: DsM (Maybe String)
+getFilename = liftDsM (\ (DsMEnv{fn_ref=md}) -> readIORef md)
+
+setFilename :: Maybe String -> DsM ()
+setFilename nm = liftDsM ( \ (DsMEnv{fn_ref=md}) -> writeIORef md nm)
+
+getInterface :: DsM (Maybe String)
+getInterface = liftDsM ( \ (DsMEnv{current_if=cur_i_ref}) -> readIORef cur_i_ref)
+
+getPath :: DsM String
+getPath = liftDsM ( \ (DsMEnv{nm_path=nm}) -> return nm)
+
+setInterface :: Maybe String -> DsM ()
+setInterface nm = liftDsM ( \ (DsMEnv{current_if=cur_i_ref}) -> writeIORef cur_i_ref nm)
+
+addToPath :: String -> DsM a -> DsM a
+addToPath nm (DsM x) = 
+  DsM (\ (env@DsMEnv{nm_path=onm}) ->
+           let new_nm = 
+	   	case onm of
+		  "" -> nm
+		  _  -> onm ++ '.':nm
+           in
+           x (env{nm_path=new_nm}))
+
+withInterface :: String -> DsM a -> DsM a
+withInterface nm act = do
+   old_nm <- getInterface
+   setInterface (Just nm)
+   v      <- act
+   setInterface old_nm
+   return v
+
+inLibrary :: DsM a -> DsM a
+inLibrary (DsM act) = liftDsM $ 
+ \ env@(DsMEnv{in_lib=in_lib_ref}) -> do
+     writeIORef in_lib_ref True
+     v      <- act env
+     writeIORef in_lib_ref False
+     return v
+
+isInLibrary :: DsM Bool
+isInLibrary = liftDsM (\ (DsMEnv{in_lib=in_lib_ref}) -> readIORef in_lib_ref)
+
+inImportedContext :: DsM a -> DsM a
+inImportedContext (DsM act) = liftDsM $
+ \ env@(DsMEnv{in_import=in_import_ref}) -> do
+     x <- readIORef in_import_ref
+     writeIORef in_import_ref True
+     v      <- act env
+     writeIORef in_import_ref x
+     return v
+
+isInImportedContext :: DsM Bool
+isInImportedContext = liftDsM (\ (DsMEnv{in_import=in_import_ref}) -> readIORef in_import_ref)
+
+pushPack :: Maybe (Maybe (String, Maybe Int)) -> DsM ()
+pushPack mb_val = liftDsM $ \ (DsMEnv{pack_stk=ps_ref}) -> do
+   ls <- readIORef ps_ref
+   case mb_val of
+     Nothing      -> writeIORef ps_ref ((Nothing,8):ls) -- default packing is 8. (ToDo: param out.)
+     Just Nothing ->
+	case ls of
+	  ((_,x):_) -> writeIORef ps_ref ((Nothing,x):ls)
+	  []        -> writeIORef ps_ref [(Nothing,8)] 
+     Just (Just ("", Just x)) -> writeIORef ps_ref ((Nothing,x):ls)
+     Just (Just (nm, Nothing)) -> 
+	case ls of
+	  ((_,x):_) -> writeIORef ps_ref ((Just nm,x):ls)
+	  []        -> writeIORef ps_ref [(Just nm,8)]
+     Just (Just (nm, Just x)) -> writeIORef ps_ref ((Just nm,x):ls)
+
+getCurrentPack :: DsM (Maybe Int)
+getCurrentPack = liftDsM $ \ (DsMEnv{pack_stk=ps_ref}) -> do
+   ls <- readIORef ps_ref
+   case ls of
+     []        -> return Nothing
+     ((_,x):_) -> return (Just x)
+
+popPack :: Maybe (String, Maybe Int) -> DsM ()
+popPack mb_i = liftDsM $ \ (DsMEnv{pack_stk=ps_ref}) -> do
+   ls <- readIORef ps_ref
+   let ls' = 
+   	case mb_i of
+	  Nothing           -> case ls of { [] -> [] ; (_:xs) -> xs }
+	  Just ("", Just v) -> case ls of { [] -> [] ; (_:xs) -> ((Nothing,v):xs) }
+	  Just (x,_)        -> scramble x ls ls
+   writeIORef ps_ref ls'
+ where
+   scramble _ ls [] = ls
+   scramble x ls ((Nothing,_):xs) = scramble x ls xs
+   scramble x ls ((Just y,_):xs) 
+       | x == y     = xs
+       | otherwise  = scramble x ls xs
+
+\end{code}
+
+\begin{code}
+addWarning :: String -> DsM ()
+addWarning msg =  liftDsM ( \ _ -> when (optVerbose || optDebug ) (hPutStrLn stderr msg))
+
+ioToDsM :: IO a -> DsM a
+ioToDsM act = liftDsM ( \ _ -> act)
+
+instance Monad DsM where
+  (>>=)  = thenDsM
+  return = returnDsM
+
+mapDsM :: (a -> b) -> DsM a -> DsM b
+mapDsM f m =  m >>= \ v -> return (f v)
+
+\end{code}
+ src/Env.lhs view
@@ -0,0 +1,79 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Oct. 16th 2001  10:39  Sigbjorn Finne $
+% @(#) $Contactid: sof@galconn.com $
+%
+
+A basic environment abstraction, hiding its representation
+(currently, finite maps..oops, wasn't suppose to tell you this :-( )
+
+\begin{code}
+module Env 
+       (
+          Env{- key elt -} -- abstract.
+        , newEnv           -- :: Env key elt
+
+	, addToEnv      -- :: Ord a => Env a b -> a -> b -> Env a b
+	, addToEnv_C    -- :: Ord a => (b -> b -> b) -> Env a b -> a -> b -> Env a b
+	, replaceElt    -- :: Ord a => Env a b -> a -> b -> Env a b
+	
+	, delFromEnv    -- :: Ord a => Env a b -> a -> Env a b
+
+	, addListToEnv   -- :: Ord a => Env a b -> [(a, b)] -> Env a b
+	, addListToEnv_C -- :: Ord a => (b -> b -> b) -> Env a b -> [(a, b)] -> Env a b
+
+	, lookupEnv      -- :: Ord a => Env a b -> a -> Maybe b
+	, envToList      -- :: Env a b -> [(a,b)]
+	
+	, mapEnv         -- :: (a -> b -> c) -> Env a b -> Env a c
+	, mapMaybeEnv    -- :: Ord a => (a -> b -> Maybe c) -> Env a b -> Env a c
+	
+	, unionEnvs      -- :: [Env a b] -> Env a b
+
+       ) where
+
+import FiniteMap
+\end{code}
+
+\begin{code}
+type Env a b = FiniteMap a b
+
+newEnv :: Env a b
+newEnv = emptyFM
+
+addToEnv :: Ord a => Env a b -> a -> b -> Env a b
+addToEnv fm key elt = addToFM fm key elt
+
+delFromEnv :: Ord a => Env a b -> a -> Env a b
+delFromEnv fm key = delFromFM fm key
+
+addToEnv_C :: Ord a => (b -> b -> b) -> Env a b -> a -> b -> Env a b
+addToEnv_C f fm key elt = addToFM_C f fm key elt
+
+-- The same behaviour as addToEnv, but it really doesn't hurt
+-- to be explicit about this.
+replaceElt :: Ord a => Env a b -> a -> b -> Env a b
+replaceElt fm key new_elt = addToFM_C (\ _ new -> new) fm key new_elt
+
+addListToEnv :: Ord a => Env a b -> [(a, b)] -> Env a b
+addListToEnv fm ls = addListToFM fm ls
+
+addListToEnv_C :: Ord a => (b -> b -> b) -> Env a b -> [(a, b)] -> Env a b
+addListToEnv_C f fm ls = addListToFM_C f fm ls
+
+lookupEnv :: Ord a => Env a b -> a -> Maybe b
+lookupEnv fm k = lookupFM fm k
+
+envToList :: Env a b -> [(a,b)]
+envToList fm = fmToList fm
+
+mapEnv :: (a -> b -> c) -> Env a b -> Env a c
+mapEnv f fm = mapFM f fm
+
+mapMaybeEnv :: Ord a => (a -> b -> Maybe c) -> Env a b -> Env a c
+mapMaybeEnv f fm = mapMaybeFM f fm
+
+unionEnvs :: (Ord a) => [Env a b] -> Env a b
+unionEnvs ls = foldl (\ acc x -> plusFM x acc) newEnv ls
+\end{code}
+ src/ErrorHook.c view
@@ -0,0 +1,45 @@+/*
+  For GHC, we override the normal 'error' function
+  prefix of "\nFail: ".
+
+  Turn off default trace msg gumpf too.
+  */
+#include <stdio.h>
+
+#if __GLASGOW_HASKELL__ >= 303
+void ErrorHdrHook (long fd)
+{}
+
+void IOErrorHdrHook (long fd)
+{}
+
+void PreTraceHook (long fd)
+{}
+
+void PostTraceHook (long fd)
+{}
+
+
+#else
+void ErrorHdrHook (FILE *where)
+{
+    fflush( stdout );			/* Flush out any pending output */
+}
+
+void IOErrorHdrHook (FILE *where)
+{
+    fflush( stdout );			/* Flush out any pending output */
+}
+
+void PreTraceHook (FILE *where)
+{
+    return;
+}
+
+void PostTraceHook (FILE *where)
+{
+    fprintf(stderr, "\n");
+    return;
+}
+
+#endif
+ src/FiniteMap.lhs view
@@ -0,0 +1,655 @@+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+\section[FiniteMap]{An implementation of finite maps}
+
+[For Hugs only.]
+
+``Finite maps'' are the heart of the compiler's
+lookup-tables/environments and its implementation of sets.  Important
+stuff!
+
+This code is derived from that in the paper:
+\begin{display}
+	S Adams
+	"Efficient sets: a balancing act"
+	Journal of functional programming 3(4) Oct 1993, pp553-562
+\end{display}
+
+The code is SPECIALIZEd to various highly-desirable types (e.g., Id)
+near the end (only \tr{#ifdef COMPILING_GHC}).
+
+\begin{code}
+module FiniteMap (
+	FiniteMap,		-- abstract type
+
+	emptyFM, unitFM, listToFM,
+
+	addToFM,
+	addToFM_C,
+	addListToFM,
+	addListToFM_C,
+	delFromFM ,
+	delListFromFM,
+
+	plusFM,
+	plusFM_C,
+	minusFM,
+	foldFM,
+
+	intersectFM ,
+	intersectFM_C ,
+	mapFM , filterFM ,
+	mapMaybeFM,
+
+	sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
+
+	fmToList, keysFM, eltsFM
+
+    ) where
+
+import Maybe( isJust )
+
+--import Bag	( foldBag )
+
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{The signature of the module}
+%*									*
+%************************************************************************
+
+\begin{code}
+--	BUILDING
+emptyFM		:: FiniteMap key elt
+unitFM		:: key -> elt -> FiniteMap key elt
+listToFM	:: (Ord key) => [(key,elt)] -> FiniteMap key elt
+			-- In the case of duplicates, the last is taken
+
+--	ADDING AND DELETING
+		   -- Throws away any previous binding
+		   -- In the list case, the items are added starting with the
+		   -- first one in the list
+addToFM		:: (Ord key) => FiniteMap key elt -> key -> elt  -> FiniteMap key elt
+addListToFM	:: (Ord key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt
+
+		   -- Combines with previous binding
+		   -- In the combining function, the first argument is the "old" element,
+		   -- while the second is the "new" one.
+addToFM_C	:: (Ord key) => (elt -> elt -> elt)
+			   -> FiniteMap key elt -> key -> elt
+			   -> FiniteMap key elt
+addListToFM_C	:: (Ord key) => (elt -> elt -> elt)
+			   -> FiniteMap key elt -> [(key,elt)]
+			   -> FiniteMap key elt
+
+		   -- Deletion doesn't complain if you try to delete something
+		   -- which isn't there
+delFromFM	:: (Ord key) => FiniteMap key elt -> key   -> FiniteMap key elt
+delListFromFM	:: (Ord key) => FiniteMap key elt -> [key] -> FiniteMap key elt
+
+--	COMBINING
+		   -- Bindings in right argument shadow those in the left
+plusFM		:: (Ord key) => FiniteMap key elt -> FiniteMap key elt
+			   -> FiniteMap key elt
+
+		   -- Combines bindings for the same thing with the given function
+plusFM_C	:: (Ord key) => (elt -> elt -> elt)
+			   -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+
+minusFM		:: (Ord key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+		   -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
+
+intersectFM	:: (Ord key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+intersectFM_C	:: (Ord key) => (elt -> elt -> elt)
+			   -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+
+--	MAPPING, FOLDING, FILTERING
+foldFM		:: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
+mapFM		:: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2
+filterFM	:: (Ord key) => (key -> elt -> Bool)
+			   -> FiniteMap key elt -> FiniteMap key elt
+mapMaybeFM      :: (Ord key)
+		=> (key -> elt1 -> Maybe elt2)
+		-> FiniteMap key elt1
+		-> FiniteMap key elt2
+
+--	INTERROGATING
+sizeFM		:: FiniteMap key elt -> Int
+isEmptyFM	:: FiniteMap key elt -> Bool
+
+elemFM		:: (Ord key) => key -> FiniteMap key elt -> Bool
+lookupFM	:: (Ord key) => FiniteMap key elt -> key -> Maybe elt
+lookupWithDefaultFM
+		:: (Ord key) => FiniteMap key elt -> elt -> key -> elt
+		-- lookupWithDefaultFM supplies a "default" elt
+		-- to return for an unmapped key
+
+--	LISTIFYING
+fmToList	:: FiniteMap key elt -> [(key,elt)]
+keysFM		:: FiniteMap key elt -> [key]
+eltsFM		:: FiniteMap key elt -> [elt]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{The @FiniteMap@ data type, and building of same}
+%*									*
+%************************************************************************
+
+Invariants about @FiniteMap@:
+\begin{enumerate}
+\item
+all keys in a FiniteMap are distinct
+\item
+all keys in left  subtree are $<$ key in Branch and
+all keys in right subtree are $>$ key in Branch
+\item
+size field of a Branch gives number of Branch nodes in the tree
+\item
+size of left subtree is differs from size of right subtree by a
+factor of at most \tr{sIZE_RATIO}
+\end{enumerate}
+
+\begin{code}
+data FiniteMap key elt
+  = EmptyFM
+  | Branch key elt	    	-- Key and elt stored here
+    Int{-STRICT-}	-- Size >= 1
+    (FiniteMap key elt)	    	-- Children
+    (FiniteMap key elt)
+\end{code}
+
+\begin{code}
+emptyFM = EmptyFM
+{-
+emptyFM
+  = Branch bottom bottom 0 bottom bottom
+  where
+    bottom = panic "emptyFM"
+-}
+
+-- #define EmptyFM (Branch _ _ 0 _ _)
+
+unitFM key elt = Branch key elt 1 emptyFM emptyFM
+
+listToFM = addListToFM emptyFM
+
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Adding to and deleting from @FiniteMaps@}
+%*									*
+%************************************************************************
+
+\begin{code}
+addToFM fm key elt = addToFM_C (\ _ new -> new) fm key elt
+
+addToFM_C _        EmptyFM key elt = unitFM key elt
+addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt
+  = case compare new_key key of
+	LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
+	GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
+	EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r
+
+addListToFM fm key_elt_pairs = addListToFM_C (\ _ new -> new) fm key_elt_pairs
+
+addListToFM_C combiner fm key_elt_pairs
+  = foldl add fm key_elt_pairs	-- foldl adds from the left
+  where
+    add f (key,elt) = addToFM_C combiner f key elt
+\end{code}
+
+\begin{code}
+delFromFM EmptyFM _ = emptyFM
+delFromFM (Branch key elt _ fm_l fm_r) del_key
+  = case compare del_key key of
+	GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
+	LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
+	EQ -> glueBal fm_l fm_r
+
+delListFromFM fm keys = foldl delFromFM fm keys
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Combining @FiniteMaps@}
+%*									*
+%************************************************************************
+
+\begin{code}
+plusFM_C _        EmptyFM fm2 = fm2
+plusFM_C _        fm1 EmptyFM = fm1
+plusFM_C combiner fm1 (Branch split_key elt2 _ left right)
+  = mkVBalBranch split_key new_elt
+		 (plusFM_C combiner lts left)
+		 (plusFM_C combiner gts right)
+  where
+    lts     = splitLT fm1 split_key
+    gts     = splitGT fm1 split_key
+    new_elt = case lookupFM fm1 split_key of
+		Nothing   -> elt2
+		Just elt1 -> combiner elt1 elt2
+
+-- It's worth doing plusFM specially, because we don't need
+-- to do the lookup in fm1.
+
+plusFM EmptyFM fm2 = fm2
+plusFM fm1 EmptyFM = fm1
+plusFM fm1 (Branch split_key elt1 _ left right)
+  = mkVBalBranch split_key elt1 (plusFM lts left) (plusFM gts right)
+  where
+    lts     = splitLT fm1 split_key
+    gts     = splitGT fm1 split_key
+
+minusFM EmptyFM _   = emptyFM
+minusFM fm1 EmptyFM = fm1
+minusFM fm1 (Branch split_key _ _ left right)
+  = glueVBal (minusFM lts left) (minusFM gts right)
+	-- The two can be way different, so we need glueVBal
+  where
+    lts = splitLT fm1 split_key		-- NB gt and lt, so the equal ones
+    gts = splitGT fm1 split_key		-- are not in either.
+
+intersectFM fm1 fm2 = intersectFM_C (\ _ right -> right) fm1 fm2
+
+intersectFM_C _        _   EmptyFM = emptyFM
+intersectFM_C _        EmptyFM _   = emptyFM
+intersectFM_C combiner fm1 (Branch split_key elt2 _ left right)
+
+  | isJust maybe_elt1	-- split_elt *is* in intersection
+  = mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left)
+						(intersectFM_C combiner gts right)
+
+  | otherwise			-- split_elt is *not* in intersection
+  = glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right)
+
+  where
+    lts = splitLT fm1 split_key		-- NB gt and lt, so the equal ones
+    gts = splitGT fm1 split_key		-- are not in either.
+
+    maybe_elt1 = lookupFM fm1 split_key
+    Just elt1  = maybe_elt1
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Mapping, folding, and filtering with @FiniteMaps@}
+%*									*
+%************************************************************************
+
+\begin{code}
+foldFM _ z EmptyFM = z
+foldFM k z (Branch key elt _ fm_l fm_r)
+  = foldFM k (k key elt (foldFM k z fm_r)) fm_l
+
+mapFM _ EmptyFM = emptyFM
+mapFM f (Branch key elt size fm_l fm_r)
+  = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r)
+
+filterFM _ EmptyFM = emptyFM
+filterFM p (Branch key elt _ fm_l fm_r)
+  | p key elt		-- Keep the item
+  = mkVBalBranch key elt (filterFM p fm_l) (filterFM p fm_r)
+
+  | otherwise		-- Drop the item
+  = glueVBal (filterFM p fm_l) (filterFM p fm_r)
+
+mapMaybeFM _ EmptyFM = emptyFM
+mapMaybeFM f (Branch key elt _ fm_l fm_r) =
+  case f key elt of
+    Nothing   -> glueVBal (mapMaybeFM f fm_l) (mapMaybeFM f fm_r)
+    Just elt' -> mkVBalBranch key elt' (mapMaybeFM f fm_l) (mapMaybeFM f fm_r)
+
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Interrogating @FiniteMaps@}
+%*									*
+%************************************************************************
+
+\begin{code}
+--{-# INLINE sizeFM #-}
+sizeFM EmptyFM		     = 0
+sizeFM (Branch _ _ size _ _) = size
+
+isEmptyFM fm = sizeFM fm == 0
+
+lookupFM EmptyFM _ = Nothing
+lookupFM (Branch key elt _ fm_l fm_r) key_to_find
+  = case compare key_to_find key of
+	LT -> lookupFM fm_l key_to_find
+	GT -> lookupFM fm_r key_to_find
+	EQ -> Just elt
+
+key `elemFM` fm
+  = case (lookupFM fm key) of { Nothing -> False; _ -> True }
+
+lookupWithDefaultFM fm deflt key
+  = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt }
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Listifying @FiniteMaps@}
+%*									*
+%************************************************************************
+
+\begin{code}
+fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm
+keysFM fm   = foldFM (\ key _   rest -> key : rest)       [] fm
+eltsFM fm   = foldFM (\ _   elt rest -> elt : rest)       [] fm
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{The implementation of balancing}
+%*									*
+%************************************************************************
+
+%************************************************************************
+%*									*
+\subsubsection{Basic construction of a @FiniteMap@}
+%*									*
+%************************************************************************
+
+@mkBranch@ simply gets the size component right.  This is the ONLY
+(non-trivial) place the Branch object is built, so the ASSERTion
+recursively checks consistency.  (The trivial use of Branch is in
+@unitFM@.)
+
+\begin{code}
+sIZE_RATIO :: Int
+sIZE_RATIO = 5
+
+mkBranch :: (Ord key) 		-- Used for the assertion checking only
+	 => Int
+	 -> key -> elt
+	 -> FiniteMap key elt -> FiniteMap key elt
+	 -> FiniteMap key elt
+
+mkBranch _{-which-} key elt fm_l fm_r
+  = --ASSERT( left_ok && right_ok && balance_ok )
+    let
+	result = Branch key elt (unbox (1 + left_size + right_size)) fm_l fm_r
+    in
+--    if sizeFM result <= 8 then
+	result
+--    else
+--	pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) (
+--	result
+--	)
+  where
+{-
+    left_ok  = case fm_l of
+		EmptyFM	 -> True
+		Branch{} -> let
+			     biggest_left_key = fst (findMax fm_l)
+			    in
+			    biggest_left_key < key
+    right_ok = case fm_r of
+		EmptyFM	 -> True
+		Branch{} -> let
+			     smallest_right_key = fst (findMin fm_r)
+			    in
+			    key < smallest_right_key
+    balance_ok = True -- sigh
+-}
+{- LATER:
+    balance_ok
+      = -- Both subtrees have one or no elements...
+	(left_size + right_size <= 1)
+-- NO	      || left_size == 0  -- ???
+-- NO	      || right_size == 0 -- ???
+    	-- ... or the number of elements in a subtree does not exceed
+	-- sIZE_RATIO times the number of elements in the other subtree
+      || (left_size  * sIZE_RATIO >= right_size &&
+    	  right_size * sIZE_RATIO >= left_size)
+-}
+
+    left_size  = sizeFM fm_l
+    right_size = sizeFM fm_r
+
+    unbox :: Int -> Int
+    unbox x = x
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection{{\em Balanced} construction of a @FiniteMap@}
+%*									*
+%************************************************************************
+
+@mkBalBranch@ rebalances, assuming that the subtrees aren't too far
+out of whack.
+
+\begin{code}
+mkBalBranch :: (Ord key)
+	    => key -> elt
+	    -> FiniteMap key elt -> FiniteMap key elt
+	    -> FiniteMap key elt
+
+mkBalBranch key elt fm_L fm_R
+
+  | size_l + size_r < 2
+  = mkBranch 1{-which-} key elt fm_L fm_R
+
+  | size_r > sIZE_RATIO * size_l	-- Right tree too big
+  = case fm_R of
+	Branch _ _ _ fm_rl fm_rr
+		| sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R
+		| otherwise	   	          -> double_L fm_L fm_R
+	-- Other case impossible
+	EmptyFM -> error "FiniteMap.mkBalBranch: the impossible happened"
+
+  | size_l > sIZE_RATIO * size_r	-- Left tree too big
+  = case fm_L of
+	Branch _ _ _ fm_ll fm_lr
+		| sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R
+		| otherwise		          -> double_R fm_L fm_R
+	-- Other case impossible
+	EmptyFM -> error "FiniteMap.mkBalBranch: the impossible happened"
+
+  | otherwise				-- No imbalance
+  = mkBranch 2{-which-} key elt fm_L fm_R
+
+  where
+    size_l   = sizeFM fm_L
+    size_r   = sizeFM fm_R
+
+    single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)
+	= mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr
+    single_L _ _ = error "FiniteMap.single_L: the impossible happened"
+
+    double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr)
+	= mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key   elt   fm_l   fm_rll)
+				 (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)
+    double_L _ _ = error "FiniteMap.double_L: the impossible happened"
+
+    single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r
+	= mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r)
+    single_R _ _ = error "FiniteMap.single_R: the impossible happened"
+
+    double_R (Branch key_l elt_l _ fm_ll (Branch key_lr elt_lr _ fm_lrl fm_lrr)) fm_r
+	= mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll  fm_lrl)
+				 (mkBranch 12{-which-} key   elt   fm_lrr fm_r)
+    double_R _ _ = error "FiniteMap.double_R: the impossible happened"
+\end{code}
+
+
+\begin{code}
+mkVBalBranch :: (Ord key)
+	     => key -> elt
+	     -> FiniteMap key elt -> FiniteMap key elt
+	     -> FiniteMap key elt
+
+-- Assert: in any call to (mkVBalBranch_C comb key elt l r),
+--	   (a) all keys in l are < all keys in r
+--	   (b) all keys in l are < key
+--	   (c) all keys in r are > key
+
+mkVBalBranch key elt EmptyFM fm_r = addToFM fm_r key elt
+mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt
+
+mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
+		     fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
+  | sIZE_RATIO * size_l < size_r
+  = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr
+
+  | sIZE_RATIO * size_r < size_l
+  = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r)
+
+  | otherwise
+  = mkBranch 13{-which-} key elt fm_l fm_r
+
+  where
+    size_l = sizeFM fm_l
+    size_r = sizeFM fm_r
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection{Gluing two trees together}
+%*									*
+%************************************************************************
+
+@glueBal@ assumes its two arguments aren't too far out of whack, just
+like @mkBalBranch@.  But: all keys in first arg are $<$ all keys in
+second.
+
+\begin{code}
+glueBal :: (Ord key)
+	=> FiniteMap key elt -> FiniteMap key elt
+	-> FiniteMap key elt
+
+glueBal EmptyFM fm2 = fm2
+glueBal fm1 EmptyFM = fm1
+glueBal fm1 fm2
+	-- The case analysis here (absent in Adams' program) is really to deal
+	-- with the case where fm2 is a singleton. Then deleting the minimum means
+	-- we pass an empty tree to mkBalBranch, which breaks its invariant.
+  | sizeFM fm2 > sizeFM fm1
+  = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)
+
+  | otherwise
+  = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2
+  where
+    (mid_key1, mid_elt1) = findMax fm1
+    (mid_key2, mid_elt2) = findMin fm2
+\end{code}
+
+@glueVBal@ copes with arguments which can be of any size.
+But: all keys in first arg are $<$ all keys in second.
+
+\begin{code}
+glueVBal :: (Ord key)
+	 => FiniteMap key elt -> FiniteMap key elt
+	 -> FiniteMap key elt
+
+glueVBal EmptyFM fm2 = fm2
+glueVBal fm1 EmptyFM = fm1
+glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
+	 fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
+  | sIZE_RATIO * size_l < size_r
+  = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr
+
+  | sIZE_RATIO * size_r < size_l
+  = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r)
+
+  | otherwise		-- We now need the same two cases as in glueBal above.
+  = glueBal fm_l fm_r
+  where
+    size_l = sizeFM fm_l
+    size_r = sizeFM fm_r
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Local utilities}
+%*									*
+%************************************************************************
+
+\begin{code}
+splitLT, splitGT :: (Ord key) => FiniteMap key elt -> key -> FiniteMap key elt
+
+-- splitLT fm split_key  =  fm restricted to keys <  split_key
+-- splitGT fm split_key  =  fm restricted to keys >  split_key
+
+splitLT EmptyFM _ = emptyFM
+splitLT (Branch key elt _ fm_l fm_r) split_key
+  = case compare split_key key of
+	LT -> splitLT fm_l split_key
+	GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
+	EQ -> fm_l
+
+splitGT EmptyFM _ = emptyFM
+splitGT (Branch key elt _ fm_l fm_r) split_key
+  = case compare split_key key of
+	GT -> splitGT fm_r split_key
+	LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
+	EQ -> fm_r
+
+findMin :: FiniteMap key elt -> (key,elt)
+findMin (Branch key elt _ EmptyFM _) = (key,elt)
+findMin (Branch _   _   _ fm_l    _) = findMin fm_l
+findMin _                            = error "FiniteMap.findMin: empty finite map"
+
+deleteMin :: (Ord key) => FiniteMap key elt -> FiniteMap key elt
+deleteMin (Branch _   _   _ EmptyFM fm_r) = fm_r
+deleteMin (Branch key elt _ fm_l    fm_r) = mkBalBranch key elt (deleteMin fm_l) fm_r
+deleteMin _                               = error "FiniteMap.deleteMin: empty finite map"
+
+findMax :: FiniteMap key elt -> (key,elt)
+findMax (Branch key elt _ _ EmptyFM) = (key,elt)
+findMax (Branch _   _   _ _ fm_r)    = findMax fm_r
+findMax _                            = error "FiniteMap.findMax: empty finite map"
+
+deleteMax :: (Ord key) => FiniteMap key elt -> FiniteMap key elt
+deleteMax (Branch _   _   _ fm_l EmptyFM) = fm_l
+deleteMax (Branch key elt _ fm_l    fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r)
+deleteMax _                               = error "FiniteMap.deleteMax: empty finite map"
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Output-ery}
+%*									*
+%************************************************************************
+
+\begin{code}
+instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
+  fm_1 == fm_2 = (sizeFM   fm_1 == sizeFM   fm_2) &&   -- quick test
+		 (fmToList fm_1 == fmToList fm_2)
+
+{- NO: not clear what The Right Thing to do is:
+instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
+  fm_1 <= fm_2 = (sizeFM   fm_1 <= sizeFM   fm_2) &&   -- quick test
+		 (fmToList fm_1 <= fmToList fm_2)
+-}
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{FiniteSets---a thin veneer}
+%*									*
+%************************************************************************
+
+\begin{code}
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Efficiency pragmas for GHC}
+%*									*
+%************************************************************************
+
+When the FiniteMap module is used in GHC, we specialise it for
+\tr{Uniques}, for dastardly efficiency reasons.
+
+\begin{code}
+\end{code}
+ src/GetOpt.lhs view
@@ -0,0 +1,282 @@+%
+% @(#) $Docid: Aug. 15th 2001  14:55  Sigbjorn Finne $
+% @(#) $Contactid: sof@galconn.com $
+%
+
+A command-line options library - sof 1/97
+[Updated to use more Haskell 1.4 features -- sof 1/98]
+
+\begin{code}
+module GetOpt
+        (
+         Opt(..)  -- instance Functor, Monad, MonadZero, MonadPlus
+
+        {- The Opt monad primitives: -}
+
+         -- add another item (to the front)
+        , pushArg   -- :: String -> Opt a ()
+         -- transform the threaded state
+        , updState  -- :: (a -> a) -> Opt a ()
+         -- aka zero
+        , failed    -- :: Opt a b
+         -- Opt try
+        , catchOpt  -- :: Opt a b -> Opt a b -> Opt a b
+
+        {- some useful Opt matchers: -}
+
+          -- match if string is prefix of current element.
+        , prefixMatch -- :: String -> Opt a String
+        , prefixed    -- :: String -> Opt a b -> Opt a b
+          -- if current option matches pred, try Opt argument.
+        , matches     -- :: (String -> Bool) -> (String -> Opt a b) -> Opt a b
+         -- test if flag is set
+        , flag        -- :: String -> (a -> a) -> Opt a ()
+        , flags       -- :: [(String,a->a)] -> Opt a ()
+         -- n-way disjunction
+        , opts        -- :: [Opt a b] -> Opt a b
+        , orOpt       -- :: Opt a b -> Opt a b -> Opt a b
+        , thenOpt     -- :: Opt a b -> Opt a b -> Opt a b
+
+          -- try matching --{disable,enable}-foo
+        , toggle     -- :: String 
+                     -- -> String 
+                     -- -> String 
+                     -- -> (Bool -> a -> a) 
+                     -- -> Opt a ()
+        , toggles    -- :: String 
+                     -- -> String 
+                     -- -> [(String,Bool -> a->a)] 
+                     -- -> Opt a ()
+
+         -- try matching -ifoo (where -i is the prefix)
+        , prefixArg  -- :: String -> (String -> a -> a) -> Opt a ()
+         -- try matching -o foo
+        , optionArg        -- :: String -> (String -> Opt a b) -> Opt a b
+        , optionWithOptArg -- :: String -> Opt a b -> Opt a b
+         -- exact string match
+        , string           -- :: String -> Opt a ()
+
+         -- useful combinators for when using attribute-lists
+         -- to gather options
+        , (-=)    -- :: String -> a -> Opt [a] ()
+        , (-==)   -- :: String -> (String -> a) -> Opt [a] ()
+        , (-===)  -- :: String -> (String -> a) -> Opt [a] ()
+        , (-====) -- :: String -> (Maybe String -> a) -> Opt [a] ()
+        , (-?)    -- :: (String -> Bool) -> (String -> a) -> Opt [a] ()
+
+          -- Do the actual matching.
+
+        , getOpts    -- :: Opt a b -> a -> [String] -> ([String],a)
+
+        ) where
+
+import Utils ( prefix )
+import Monad
+
+infixr 1  `bindOpt`, `seqOpt`
+-- needed for older Hugsen.
+infixl 9 `orOpt`
+\end{code}
+
+Use a monad to encode the matching operations we want
+to do on the command line contents, threading a value
+that will record what we've seen so far plus the remainder
+of the command-line.
+
+\begin{code} 
+data Opt a b = Opt ([String] -> a -> Maybe ([String],a,b))
+
+-- bind & return over Opt
+bindOpt :: Opt a b -> (b -> Opt a c) -> Opt a c
+bindOpt (Opt opt_a) fopt = Opt (\ args st ->
+   case opt_a args st of
+     Nothing            -> Nothing
+     Just (args',st',v) -> 
+       case fopt v of Opt opt_b -> opt_b args' st')
+
+seqOpt :: Opt a b -> Opt a c -> Opt a c
+seqOpt a b = a `bindOpt` (\ _ -> b)
+
+returnOpt :: b -> Opt a b
+returnOpt v = Opt (\ args st -> Just (args,st,v))
+
+{-
+  The Opt primitives for pop and push of cmd line options, plus
+  primitive for updating the threaded state.
+-}
+
+pushArg :: String -> Opt a ()
+pushArg str = Opt (\ args st -> Just (str:args,st,()))
+
+popArg :: Opt a String
+popArg = Opt (\ args st ->
+     case args of
+       []     -> Nothing
+       (x:xs) -> Just (xs,st,x)
+    )
+
+updState :: (a -> a) -> Opt a ()
+updState f = Opt (\ args st -> Just (args, f st, ()))
+
+{-
+result :: a -> Opt a ()
+result v = updState (\ _ -> v)
+-}
+  
+ -- a not-that-useful operation on Opt.
+mapOpt :: (b -> c) -> Opt a b -> Opt a c
+mapOpt f (Opt opt) = Opt (\ args st ->
+        case opt args st of
+          Nothing -> Nothing
+          Just (args',st',v) -> Just (args',st',f v))
+
+-- Let's overload!
+
+instance Monad (Opt s) where
+  a >>= b = bindOpt a b
+  return  = returnOpt
+
+instance Functor (Opt s) where
+  fmap = mapOpt
+
+instance MonadPlus (Opt s) where
+  mplus = thenOpt    
+  mzero = failed
+  
+ -- no match.
+failed :: Opt a b
+failed = Opt (\ _ _ -> Nothing)
+
+
+-- try left, if not successful, give right a spin.
+
+catchOpt :: Opt a b -> Opt a b -> Opt a b
+catchOpt (Opt opt_a) (Opt opt_b) = Opt (\ args st ->
+     case opt_a args st of
+       Nothing -> opt_b args st
+       Just x  -> Just x)
+\end{code}
+
+Scanning a list of command-line options using
+an Opt action that encodes what's interesting and
+worth noting.
+
+ToDo: add error support (in the monad?)
+
+\begin{code}
+getOpts :: Opt a b -> a -> [String] -> ([String],a)
+getOpts _ st []                    = ([],st)
+getOpts o@(Opt opt) st args@(x:xs) =
+  case opt args st of
+   Nothing            -> let (args',st') = getOpts o st xs in (x:args',st')
+   Just (args',st',_) -> getOpts o st' args'
+
+\end{code}
+
+A number of useful matching combinators for command-line
+options follow:
+
+\begin{code}
+prefixMatch :: String -> Opt a String
+prefixMatch str = do
+  arg <- popArg
+  case prefix str arg of
+   Nothing   -> failed
+   Just arg' -> return arg'
+
+prefixed :: String -> Opt a b -> Opt a b
+prefixed pre n_opt = do
+  arg <- prefixMatch pre
+   -- push back what's left of the option, and continue.
+  pushArg arg
+  n_opt
+
+
+matches :: (String -> Bool) -> (String -> Opt a b) -> Opt a b
+matches matcher opt = do
+   arg <- popArg
+   if matcher arg 
+    then opt arg
+    else failed
+
+flag :: String -> (a -> a) -> Opt a ()
+flag str f = do
+   arg <- popArg
+   case prefix str arg of
+    Nothing   -> failed
+    Just{}    -> updState f
+
+opts :: [Opt a b] -> Opt a b
+opts ls = foldl1 (orOpt) ls
+
+orOpt :: Opt a b -> Opt a b -> Opt a b
+orOpt = catchOpt
+
+thenOpt :: Opt a b -> Opt a b -> Opt a b
+thenOpt opt_a opt_b = opt_a `seqOpt` opt_b
+\end{code}
+
+
+\begin{code}
+flags :: [(String,a->a)] -> Opt a ()
+flags ls = opts (map (\ (str,f) -> flag str f) ls)
+
+toggle :: String -> String -> String -> (Bool -> a -> a) -> Opt a ()
+toggle on off str f =
+ ((prefixed on  (returnOpt True))   `orOpt`
+  (prefixed off (returnOpt False))) >>= \ flg ->
+ prefixed str (popArg >> updState (f flg))
+
+toggles :: String -> String -> [(String,Bool -> a->a)] -> Opt a ()
+toggles on off ls = opts (map (\ (str,f) -> toggle on off str f) ls)
+
+prefixArg :: String -> (String -> a -> a) -> Opt a ()
+prefixArg str f = do
+  arg <- popArg
+  case prefix str arg of
+   Nothing   -> failed
+   Just arg' -> updState (f arg')
+
+optionArg :: String -> (String -> Opt a b) -> Opt a b
+optionArg str f = do
+    -- get current option
+   arg <- popArg
+   case prefix str arg of
+    Nothing  -> failed
+    Just{}   -> do
+        -- get option value
+       arg' <- popArg
+       f arg'
+
+optionWithOptArg :: String -> Opt a b -> Opt a b
+optionWithOptArg str f = do
+  arg <- popArg
+  case prefix str arg of
+   Nothing  -> failed
+   Just _   -> f
+
+string :: String  -> Opt a ()
+string str =  do
+  rest <- prefixMatch str
+  case rest of
+    [] -> returnOpt ()
+    _  -> failed
+  
+(-=) :: String -> a -> Opt [a] ()
+(-=) str v = flag str (v:)
+
+(-==) :: String -> (String -> a) -> Opt [a] ()
+(-==) str f = prefixArg str (\ ls -> ((f ls):))
+
+(-===) :: String -> (String -> a) -> Opt [a] ()
+(-===) str f = optionArg str (\ val -> updState ((f val):))
+
+(-====) :: String -> (Maybe String -> a) -> Opt [a] ()
+(-====) str f = 
+  optionWithOptArg 
+   str 
+   (popArg >>= \ val -> updState ((f (Just val)):))
+ 
+(-?) :: (String -> Bool) -> (String -> a) -> Opt [a] ()
+(-?) matcher f = matches matcher (\ ls -> updState ((f ls):))
+\end{code}
+ src/HugsCodeGen.lhs view
@@ -0,0 +1,323 @@+%
+% (c) 1999, University of Glasgow & Sigbjorn Finne
+%
+
+Backend which emits C stubs compatible with Hugs' 'primitive' declarations.
+
+\begin{code}
+module HugsCodeGen ( hugsCodeGen ) where
+
+import AbstractH
+import AbsHUtils ( splitFunTys, isIOTy )
+import PP
+import BasicTypes
+import Utils ( traceIf )
+import Opts  ( optVerbose, optLongLongIsInteger,
+	       optGenHeader, optOneModulePerInterface
+	     )
+import List  ( nub, intersperse )
+import Utils ( notNull, dropSuffix )
+\end{code}
+
+\begin{code}
+hugsCodeGen :: String		-- (base)name of output file
+	    -> [HTopDecl]	-- Haskell decls to derive Hugs stubs from.
+	    -> String
+hugsCodeGen c_nm ls = showPPDoc (hCode c_nm ls) ([],[])
+
+type HugsStubCode = PPDoc ([(String,Int)],[String])
+
+getStubEnv :: ([(String,Int)] -> HugsStubCode) -> HugsStubCode
+getStubEnv cont env@(e,_) = cont e env
+
+getDllEnv :: ([String] -> HugsStubCode) -> HugsStubCode
+getDllEnv cont env@(_,e) = cont e env
+
+addToStubEnv :: String -> Type -> HugsStubCode -> HugsStubCode
+addToStubEnv nm ty cont (env,dlls) = cont (((nm,arity):env),dlls)
+  where
+   (args,res) = splitFunTys ty
+
+   sizeofArg (TyCon tc) | optLongLongIsInteger && qName tc == "Integer" = (2::Int)
+   sizeofArg _ = 1
+
+   size_args = sum (map sizeofArg args)
+
+   arity 
+    | isIOTy res = size_args + 2
+    | otherwise  = size_args
+   
+addToDllEnv :: String -> HugsStubCode -> HugsStubCode
+addToDllEnv nm cont (env,dlls) = cont (env,nm:dlls)
+
+hCode :: String -> [HTopDecl] -> HugsStubCode
+hCode c_nm xs = whizz xs
+ where 
+  whizz [] = 
+    getDllEnv  $ \ dlls ->
+    let dlls_real = nub (filter notNull dlls) in
+    traceIf (optVerbose && notNull dlls_real)
+            ("\nStubs depend on entry points from the following DLLs/libraries:\n  " ++
+	     showList dlls_real (
+	     "\nyou may need to adjust your command-line when compiling the stubs to" ++
+	     "\ntake this into account.")) $
+    getStubEnv $ \ env ->
+    genTrailer env
+  whizz (HLit _ : ls)     = whizz ls
+  whizz (CLit s : ls) 
+    | not optGenHeader  = text s $$ whizz ls
+    | otherwise         = whizz ls
+  whizz (HInclude s : ls) = text "#include" <+> text (escapeString s) $$
+  			    whizz ls
+  whizz (HMod hm : ls)    = hMod c_nm hm (whizz ls)
+
+  escapeString s@('"':_) = s -- "
+  escapeString s@('<':_) = s
+  escapeString s         = show s
+ 
+hMod :: String -> HModule -> HugsStubCode -> HugsStubCode
+hMod c_nm (HModule _ _ _ _ d) cont
+  | optGenHeader && not optOneModulePerInterface = 
+      text  "#include" <+> text (show (dropSuffix c_nm ++ ".h")) $$ code
+  | otherwise = code
+ where
+  code = hDecl d cont
+
+hDecl :: HDecl -> HugsStubCode -> HugsStubCode
+hDecl (AndDecl d1 d2) cont = hDecl d1 (hDecl d2 cont)
+hDecl (Primitive _ cc lspec nm ty _ c_args c_res) cont =
+ addToDllEnv dll_name $
+ addToStubEnv nm ty   $
+ tdefFun lspec cc c_args c_res $$
+ primHeader nm $$ 
+ lbrace $$
+   argAndResDecls ty c_args c_res $$ argAssign ty c_args $$
+   performCall False lspec c_args ty $$
+   pushResult c_res ty $$
+ rbrace $$
+ cont
+ where
+  (dll_name, _, _, _) = lspec
+
+  tdefFun (_,Nothing,_,_) _ _ _ = empty
+  tdefFun (_,Just _,fnm,_) cconv cargs cres = 
+    text "extern" <+> text (snd cres) <+> ppCallConv True cconv <+> text fnm <+>
+    parens (hsep (intersperse comma (map (text.snd) cargs))) <> semi
+
+hDecl (PrimCast cc nm ty _ c_args c_res) cont =
+ addToStubEnv nm ty              $
+ tdefFunTy nm cc c_args c_res $$
+ primHeader nm $$ 
+ lbrace $$
+   argAndResDecls ty c_args c_res $$ 
+   text (nm++"__funptr __funptr__;") $$
+   argAssign ty c_args $$
+   text ("__funptr__ = ("++nm++"__funptr)arg0;") $$
+   performCall True ("", Nothing, "__funptr__", Nothing) c_args ty $$
+   pushResult c_res ty $$
+ rbrace $$
+ cont
+
+hDecl (Include s) cont = text ("#include " ++ s) $$ cont
+hDecl (CCode s)   cont
+ | not optGenHeader  = text s $$ cont
+ | otherwise         = cont
+hDecl _ cont = cont
+
+\end{code}
+
+\begin{code}
+primHeader :: Name -> HugsStubCode
+primHeader nm = text "primFun" <> parens (text nm)
+
+argAndResDecls :: Type -> [(Bool,String)] -> (Bool,String) -> HugsStubCode
+argAndResDecls ty c_args c_res = ppDecls (zipWith declArg [0..] c_args) $$ declRes 
+ where
+  (_, res) = splitFunTys ty
+
+  declRes
+   | noResult   = empty
+   | otherwise  = text (snd c_res) <+> text "res" <> semi
+
+  declArg n (is_struct,t)
+    | is_struct = text t <> char '*' <+> ppArg False n
+    | otherwise = text t <+> ppArg False n
+
+  noResult =
+    case res of 
+     (TyApply (TyCon _) [TyCon tc]) -> qName tc == "()"
+     _ -> False
+
+ppArg :: Bool -> Int -> HugsStubCode
+ppArg isStructTy n 
+ | isStructTy = text ("*arg"++show n)
+ | otherwise  = text ("arg"++show n)
+
+ppCTy :: Type -> HugsStubCode
+ppCTy ty = 
+ case ty of
+   TyVar _ tv    -> text (degrokNm (qName tv))
+   TyCon tc      
+     | qName tc == "()" -> empty
+     | otherwise	-> text (degrokNm (qName tc))
+   TyApply (TyCon tc) [_] | qName tc == "StablePtr"  -> text "StablePtr"
+   TyApply (TyCon tc) [_] | qName tc == "Ptr"        -> text "Addr"
+   TyApply (TyCon tc) [_] | qName tc == "FunPtr"     -> text "Addr"
+   TyApply (TyCon tc) [_] | qName tc == "ForeignPtr" -> text "Foreign"
+   TyApply _ [t] -> ppCTy t   -- catches (IO t)
+   TyApply t _   -> ppCTy t
+   TyList  _     -> text "void*"
+   TyTuple _     -> text "void*"
+   TyFun _ _     -> text "void*"
+   TyCtxt _ t    -> ppCTy t
+ where
+  degrokNm nm =
+     case nm of
+      'I':'n':'t':_     -> "Int"
+      'W':'o':'r':'d':_ -> "Word"
+      'F':'o':_		-> "Foreign"
+      "Char"            -> "Char"
+      "Double"          -> "Double"
+      "Float"           -> "Float"
+      _			-> "Addr"
+
+argAssign :: Type -> [(Bool,String)] -> HugsStubCode
+argAssign ty c_args = ppDecls (zipWith3 declArg [0..] args c_args)
+  where
+  (args, _) = splitFunTys ty
+
+  declArg n t@(TyCon tc) (_, c_ty) 
+    | optLongLongIsInteger && qName tc == "Integer"
+    = ppArg False n <+> equals    <+>
+	parens (text c_ty) <>
+	parens (text"hugs->get" <> ppCTy t <> text "()") <> semi $$
+	ppArg False n <+> text ">>= 32" <> semi $$
+	ppArg False n <+> text "+=" <+> parens (text c_ty) <> 
+	      parens (text"hugs->get" <> ppCTy t <> text "()")
+  declArg n t (is_struct, c_ty) 
+     = ppArg False n <+> equals    <+>
+	parens ppr_c_ty <>
+	parens (text"hugs->get" <> ppCTy t <> text "()")
+   where
+    ppr_c_ty
+      | is_struct = text c_ty <> char '*'
+      | otherwise = text c_ty 
+
+\end{code}
+
+\begin{code}
+performCall :: Bool -> LocSpec -> [(Bool,String)] -> Type -> HugsStubCode
+performCall is_dyn (_,_, fun, _) c_args ty = 
+   ppAssign res <> text fun <> pp_fun_args <> semi
+ where
+  (args, res) = splitFunTys ty
+
+  pp_fun_args
+    | not (isIOTy res) && null args = empty -- hack to cope with constants
+    | otherwise = ppTuple fun_args
+
+  fun_args
+    | is_dyn    = tail funArgs
+    | otherwise = funArgs
+
+  funArgs = zipWith funArg [0..] c_args
+
+  funArg n (isStructTy,_) = ppArg isStructTy n
+
+  ppAssign (TyApply (TyCon _) [TyCon tc])
+    | qName tc == "()" = empty
+  ppAssign _	       = text "res" <+> equals
+
+\end{code}
+
+\begin{code}
+pushResult :: (Bool,String) -> Type -> HugsStubCode
+pushResult (isStructTy, c_ty) ty = 
+  assignRes $$
+  if isPure then 
+      empty
+  else
+      text "hugs_returnIO" <> parens no_of_args <> semi
+ where 
+  (_, res) = splitFunTys ty
+
+  isPure = 
+    case res of 
+      TyApply _ _ -> False
+      _           -> True
+
+  noResult =
+    case res of 
+     (TyApply (TyCon _) [TyCon tc]) -> qName tc == "()"
+     _ -> False
+
+  isIntegerRes =
+    case res of 
+     (TyApply (TyCon _) [TyCon tc]) -> qName tc == "Integer"
+     _ -> False
+     
+  assignRes
+    | noResult  = empty
+    | isIntegerRes = text "hugs->putInt" <> parens ( text "(unsigned int)res" ) <> semi $$
+		     text "hugs->putInt" <> parens ( text "(unsigned int)(res >> 32)" ) <> semi
+    | otherwise = text "hugs->put" <> (ppCTy res) <>
+		  parens (the_result) <> semi
+
+  the_result
+    | isStructTy = text "copyBytes" <> parens (
+  	                text "sizeof" <> parens (text c_ty) <>
+                        text ", &res")
+    | otherwise  = parens (text c_ty) <> text "res" 
+
+  no_of_args
+    | noResult     = text "0"
+    | isIntegerRes = text "2"
+    | otherwise    = text "1"
+
+\end{code}
+
+\begin{code}
+tdefFunTy :: Name -> CallConv -> [(Bool,String)] -> (Bool,String) -> HugsStubCode
+tdefFunTy nm cc c_args c_res =
+ text "typedef" <+> ppResultTy <+>
+   parens ( ppCallConv True cc <+> char '*' <+> 
+	    text (nm++"__funptr")) <+>
+   ppTuple ppArgs <> semi
+ where
+  ppResultTy  = text (snd c_res)
+  ppArgs = zipWith pp_arg [1..] (tail c_args)
+  
+  pp_arg n (_, t) = text t <+> ppArg False n
+
+\end{code}
+
+\begin{code}
+genTrailer :: [(String,Int)] -> HugsStubCode
+genTrailer [] = empty
+genTrailer ls = 
+  genPrimTable ls $$
+  text "static struct hugs_primInfo prims = { 0, primTable, 0 };" $$
+  text "#ifdef __cplusplus" $$
+  text "extern \"C\" {" $$
+  text "#endif" $$
+  text "DLLEXPORT(void) initModule(HugsAPI4 *);" $$
+  text "DLLEXPORT(void) initModule(HugsAPI4 *hugsAPI) {" $$
+  text "  hugs = hugsAPI;" $$
+  text "  hugs->registerPrims(&prims);" $$
+  text "}" $$
+  text "#ifdef __cplusplus" $$
+  text "}"  $$
+  text "#endif"
+  
+genPrimTable :: [(String,Int)] -> HugsStubCode
+genPrimTable ls = 
+  text "static struct hugs_primitive primTable[] = {" $$
+  nest 2 (vsep (map genPrim ls)) $$
+  nest 2 (text "{0,0,0}") $$
+  text "};"
+ where
+  genPrim (nm, arity) = 
+     lbrace <> text (show nm) <> comma <> text (show arity) <> comma <>
+     text nm <> text "},"
+
+\end{code}
+ src/IDLSyn.lhs view
@@ -0,0 +1,159 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Aug. 28th 2001  12:06  Sigbjorn Finne $
+% @(#) $Contactid: sof@galconn.com $
+%
+
+Abstract Syntax Tree for OMG/MS IDL
+
+Declarations:
+\begin{code}
+module IDLSyn where
+
+import Literal
+import BasicTypes
+
+\end{code}
+
+The abstract syntax for declarations/definitions in IDL.
+
+\begin{code}
+data Defn 
+ = Typedef    Type [Attribute] [Id]
+ | TypeDecl   Type  --structs, unions (w/ tag) and enums.
+ | ExternDecl Type [Id]
+ | Constant   Id [Attribute] Type Expr
+ | Attributed [Attribute] Defn
+ | Attribute  [Id] Bool Type
+ | Operation  Id Type {-[Param]-} (Maybe Raises) (Maybe Context)
+ | Exception  Id [Member]
+ | Interface  Id Inherit [Defn]
+ | Forward    Id
+   -- MS specific declaration groups:
+ | Module        Id [Defn]
+ | DispInterface Id [([Attribute],Type,Id)] [Defn]
+ | DispInterfaceDecl Id Id
+ | CoClass Id [CoClassMember]
+ | Library Id [Defn]
+ | CppQuote String
+ | HsQuote  String
+ | CInclude String
+ | Import    [(String,[Defn])]
+ | ImportLib    String -- importing a type library.
+ | Pragma       String
+ | IncludeStart String
+ | IncludeEnd
+   deriving ( Eq )
+
+\end{code}
+
+An identifier could be followed by bracketed expressions(?)
+specifying the dimensions of the array, i.e., foo[2][3]
+
+Notice that it is convenient for the parser to associate
+attributes with definitions and parameters, and not with IDL
+Ids directly (as is done in CoreIDL).
+
+That being said, an 'attributed Id' is also provided, not used
+by the parser, but the desugarer employs it to decorate Ids
+prior to CoreIDL translation.
+
+\begin{code}
+data Id 
+ = Id String 
+ | AttrId  [Attribute] Id  
+ | ArrayId Id [Expr]  -- 0,1 or 2 expressions.
+ | Pointed [[Qualifier]] Id
+ | CConvId CallConv Id
+ | BitFieldId Int   Id
+ | FunId Id (Maybe CallConv) [Param]
+   deriving ( Eq )
+ 
+\end{code}
+
+Big type encoding type constants and constructors provided
+with IDL.
+
+\begin{code}
+data Type
+ = TyApply Type Type
+ | TyInteger Size
+ | TyFloat   Size
+ | TyStable
+ | TyChar
+ | TySigned  Bool
+ | TyWChar
+ | TyBool   
+ | TyOctet
+ | TyAny    
+ | TyObject
+ | TyStruct (Maybe Id) [Member] (Maybe Int)
+ | TyString (Maybe Expr)
+ | TyWString (Maybe Expr)
+ | TySequence Type (Maybe Expr)
+ | TyFixed (Maybe (Expr, IntegerLit))
+ | TyName String (Maybe Type)
+ | TyIface Name
+ | TyUnion (Maybe Id) Type Id (Maybe Id) [Switch] -- encapsulated union.
+ | TyEnum (Maybe Id) [(Id, [Attribute], Maybe Expr)]
+   -- MS specific types:
+ | TyUnionNon (Maybe Id) [Switch] -- non-encapsulated union.
+ | TyCUnion (Maybe Id) [Member]
+            (Maybe Int)     -- C-style union.
+ | TyBString
+ | TyPointer Type
+ | TyArray Type [Expr]
+ | TySafeArray Type
+ | TyFun (Maybe CallConv) Type [Param]
+ | TyVoid
+ | TyQualifier Qualifier
+   deriving ( Eq )
+
+data Expr
+ = Binary BinaryOp Expr Expr
+ | Cond   Expr Expr Expr
+ | Unary  UnaryOp Expr
+ | Var    Name
+ | Lit    Literal
+ | Cast   Type Expr
+ | Sizeof Type
+   deriving ( Eq )
+
+type Raises = [Name]
+type Context = [String]
+
+type CoClassMember = (Bool, Id, [Attribute])
+
+data Param      = Param Id Type [Attribute]
+		  deriving ( Eq )
+
+type Member     = (Type, [Attribute], [Id])
+
+data Attribute  
+ = Attrib Id [AttrParam]  -- name(e1,..,en)
+ | Mode ParamDir
+   deriving ( Eq )
+
+data AttrParam 
+  = AttrExpr Expr
+  | EmptyAttr         -- size_is(,e) => [EmptyAttr,attr_param e]
+  | AttrLit Literal
+  | AttrPtr AttrParam
+   deriving ( Eq )
+
+data Switch    = Switch [CaseLabel] (Maybe SwitchArm) 
+		 deriving ( Eq )
+data CaseLabel = Case [Expr] | Default
+		 deriving ( Eq )
+
+-- switch arms can have attributes along with type and
+-- declarator, just as proc. params.
+type SwitchArm = Param
+
+data GNUAttrib
+ = Packed
+ | CConv         CallConv
+ | Unsupported   String
+   deriving (Eq)
+\end{code}
+ src/IDLToken.lhs view
@@ -0,0 +1,271 @@+%
+% @(#) $Docid: Sep. 19th 2001  12:01  Sigbjorn Finne $
+% @(#) $Contactid: sof@galconn.com $
+%
+
+
+\begin{code}
+module IDLToken where
+
+import IDLSyn
+import BasicTypes
+import Literal
+import SrcLoc
+import Opts ( optCompilingDceIDL
+	    , optCompilingMsIDL
+	    , optCompilingOmgIDL
+	    , optJNI
+	    )
+\end{code}
+
+Tedious type giving all the lexemes that are
+passed between lexer and parser. Highlights:
+
+  * "uuid(guid)" is one lexeme - the interaction
+    between lexing guids and numbers made this
+    convenient. [No loss, I'm not aware of guids
+    being used outside the uuid() attribute in IDL.]
+  * As is the case when parsing C with Yacc, we choose
+    to get around the problem of parsing typedefs by
+    installing parsed typedef names into the symbol
+    table being threaded by the lexer monad.  
+
+    Hence, subsequent uses of the typedef'ed name will
+    be reported as T_tdef_name lexemes rather than as
+    ordinary ids (T_id.)
+
+    [ToDo: check if there's not alternative ways of doing
+     this.]
+
+\begin{code}
+data IDLToken
+ = T_semi
+ | T_module
+ | T_interface
+ | T_oparen
+ | T_cparen
+ | T_ocurly
+ | T_ccurly
+ | T_colon
+ | T_dcolon
+ | T_const
+ | T_volatile
+ | T_equal
+ | T_eqeq
+ | T_neq
+ | T_negate
+ | T_rel_or
+ | T_or
+ | T_xor
+ | T_rel_and
+ | T_and
+ | T_shift ShiftDir
+ | T_div
+ | T_mod
+ | T_not
+ | T_typedef
+ | T_extern
+ | T_comma
+ | T_dot
+ | T_dotdotdot
+ | T_float    Size
+ | T_int      Size
+ | T_uint     Size
+ | T_unsigned
+ | T_signed
+ | T_sizeof
+ | T_char
+ | T_wchar
+ | T_boolean
+ | T_octet
+ | T_any
+ | T_object
+ | T_struct
+ | T_union
+ | T_switch
+ | T_case
+ | T_default
+ | T_enum
+ | T_question
+ | T_lt
+ | T_le
+ | T_gt
+ | T_ge
+ | T_osquare
+ | T_csquare
+ | T_exception
+ | T_void
+ | T_mode ParamDir
+ | T_raises
+ | T_context
+ | T_fixed
+ | T_idl_type	Type
+ | T_type       String
+ | T_literal    Literal
+ | T_string_lit String
+ | T_wstring_lit String
+ | T_callconv   CallConv
+ | T_pragma     String -- everything after '#pragma'
+ | T_id String
+ | T_dispinterface
+ | T_coclass
+ | T_library
+ | T_plus
+ | T_times
+ | T_minus
+ | T_safearray
+ | T_sequence
+ | T_string
+ | T_wstring
+ | T_readonly
+ | T_attribute
+ | T_methods
+ | T_properties
+ | T_import
+ | T_include_start String
+ | T_include_end
+ | T_gnu_attribute
+ | T_importlib
+ | T_oneway
+ | T_cpp_quote
+ | T_hs_quote
+ | T_include String
+ | T_hdefine
+ | T_unknown (SrcLoc,String)
+ | T_ignore_start
+ | T_eof
+--   deriving Show
+\end{code}
+
+Keywords for the different flavours of IDL we support:
+
+\begin{code}
+idlKeywords :: [(String, IDLToken)]
+idlKeywords 
+  | optCompilingDceIDL = dce_keywords
+  | optCompilingMsIDL  = midl_keywords
+  | optCompilingOmgIDL = omg_keywords
+  | otherwise	       = omg_keywords
+
+-- keywords shared by all the IDL dialects we support.
+std_idl_keywords :: [(String, IDLToken)]
+std_idl_keywords =
+    (if optJNI then
+        (("Object",   T_idl_type TyObject):)
+     else
+        id)
+    [ ("boolean",	T_type "bool")
+    , ("case",          T_case)
+    , ("char",          T_char)
+    , ("const",  	T_const)
+    , ("default",  	T_default)
+    , ("double",  	T_float Long)
+    , ("enum",		T_enum)
+    , ("float",  	T_float Short)
+    , ("in",  	        T_mode In)
+    , ("interface",	T_interface)
+    , ("import",	T_import)
+    , ("long",          T_int Long)
+    , ("int",           T_int Natural)
+    , ("module",        T_module)
+    , ("out",           T_mode Out)
+    , ("short",         T_int Short)
+    , ("signed",        T_signed)
+    , ("sizeof",        T_sizeof)
+    , ("struct",        T_struct)
+    , ("switch",        T_switch)
+    , ("typedef",	T_typedef)
+    , ("unsigned",      T_unsigned)
+    , ("union",		T_union)
+    , ("void",		T_void)
+    , ("wchar",		T_wchar)
+    , ("wstring",	T_wstring)
+    , ("FALSE",         T_literal (BooleanLit False))
+    , ("TRUE",          T_literal (BooleanLit True))
+    , ("NULL",		T_literal NullLit)
+    , ("byte",		T_type "octet")
+    , ("stablePtr",	T_idl_type TyStable)
+    , ("extern",	T_extern)
+          -- FIXME: normalise callconv naming with cpp
+    , ("__stdcall",	T_callconv Stdcall)  
+    , ("__stdcall__",	T_callconv Stdcall)  
+    , ("__cdecl",	T_callconv Cdecl)
+    , ("__cdecl__",	T_callconv Cdecl)
+    , ("_stdcall",	T_callconv Stdcall)
+    , ("_cdecl",	T_callconv Cdecl)
+    , ("stdcall",	T_callconv Stdcall)
+    , ("cdecl",	        T_callconv Cdecl)
+    , ("__attribute__", T_gnu_attribute)
+    ] 
+
+dce_keywords :: [(String, IDLToken)]
+dce_keywords = std_idl_keywords ++ dce_idl_keywords
+
+dce_idl_keywords :: [(String, IDLToken)]
+dce_idl_keywords =
+ [ ("byte",		T_type "octet")
+ , ("error_status_t",   T_type "error_status_t")
+ , ("small",		T_int Short)
+ ] 
+
+
+midl_keywords :: [(String, IDLToken)]
+midl_keywords = std_idl_keywords ++ dce_idl_keywords ++ ms_idl_keywords
+
+ms_idl_keywords :: [(String, IDLToken)]
+ms_idl_keywords = 
+      [ ("IDispatch",	   T_type "IDispatch")
+      , ("IUnknown",	   T_type "IUnknown")
+      , ("HRESULT",	   T_type "HRESULT")
+      , ("DATE",	   T_type "DATE")
+      , ("CURRENCY",	   T_type "CURRENCY")
+      , ("VARIANT",	   T_type "VARIANT")
+      , ("VARIANT_BOOL",   T_type "VARIANT_BOOL")
+      , ("BSTR",	   T_type "BSTR")
+      , ("SAFEARRAY",      T_safearray)
+      , ("hyper",	   T_int LongLong)
+      , ("__int8",	   T_octet)
+      , ("__int16",	   T_int Short)
+      , ("__int32",	   T_int Long)
+      , ("__int64",	   T_int LongLong)
+--      , ("int64",	   T_int LongLong)
+--      , ("uint64",	   T_uint LongLong)  -- this one, ugh!
+					    
+      , ("coclass",	   T_coclass)
+      , ("cpp_quote",  	   T_cpp_quote)
+      , ("dispinterface",  T_dispinterface)
+      , ("single",  	   T_float Short)  -- VBism?
+      , ("importlib",	   T_importlib)
+      , ("library",	   T_library)
+      , ("methods",        T_methods)
+      , ("properties",     T_properties)
+      , ("bool",	   T_type "bool")
+      , ("volatile",  	   T_volatile)
+      , ("wchar_t",  	   T_type "wchar_t")
+         -- The next two are local extensions.
+      , ("hs_quote",  	   T_hs_quote)
+      , ("stub_include",   T_include "")
+      , ("__ignore_start__", T_ignore_start)
+      ]      
+
+omg_keywords :: [(String, IDLToken)]
+omg_keywords = std_idl_keywords ++ omg_idl_keywords
+
+omg_idl_keywords :: [(String, IDLToken)]
+omg_idl_keywords = 
+  [ ("any",	   T_any)
+  , ("attribute",  T_attribute)
+  , ("context",    T_context)
+  , ("exception",  T_exception)
+  , ("fixed",  	   T_fixed)
+  , ("inout",      T_mode InOut)
+  , ("Object",     T_object)
+  , ("octet",      T_octet)
+  , ("oneway",     T_oneway)
+  , ("raises",     T_raises)
+  , ("readonly",   T_readonly)
+  , ("sequence",   T_sequence)
+  , ("string",     T_string)
+  ]
+
+\end{code}
+ src/IDLUtils.lhs view
@@ -0,0 +1,1039 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Aug. 21th 2003  08:42  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Misc utilities to help out the desugarer.
+
+\begin{code}
+module IDLUtils 
+
+       ( iName
+       , noAttrs
+       , removeIdAttrs
+       , idAttrs
+
+       , isUnpointedId
+       , isConstructedTy
+       , isCompleteTy
+       , isReferenceTy
+       , isMIDLishTy
+       , isMIDLishId
+       , isFunTy
+       , isEmptyStructTy
+       , isAnonTy
+
+       , tyTag
+       , withTyTag
+       , getTyQual
+       , mkReferenceTy
+       
+       , getTyTag
+       
+       , isVoidTyDef
+
+       , reduceExpr
+
+       , isLeafDefn
+       
+       , tyShort
+       , tyWord16
+       , tyInt16
+       , tyWord32
+       , tyInt32
+       , tyGUID
+       , tyIDispatch
+       , tyVARIANT
+       , tySafeArray
+       , tyCURRENCY
+       , tyDATE
+       , tyFILETIME
+       , tyAddr
+       , tyVoid
+       , tyIStream
+       , tyIStorage
+       , tyChar
+       , tyWord64
+       , tyInt64
+       , tyByte
+       , tyVariantBool
+       , tyIUnknown
+       , tyHRESULT
+       , tyBSTR
+       , tyString
+       , tyWString
+       , tyFloat
+       , tyDouble
+       , tyInt
+
+       , retValAttribute
+       , defaultAttribute
+       , lcidAttribute
+       , optionalAttribute
+       , controlAttribute
+       , restrictedAttribute
+       , hiddenAttribute
+       , versionAttr
+       , helpStringAttr
+       , helpContextAttr
+       , helpFileAttr
+       , helpStringDllAttr
+       , helpStringCtxtAttr
+       , lcidvalAttribute
+       
+       , mkFunId
+       , mkMethodId
+       , massageId
+       
+       , sortDefns
+       , winnowDefns
+       
+       , exprToName
+       , exprType
+       , transferPointedness
+       
+       , toCConvAttrib
+       , toPackedAttrib
+       , mkGNUAttrib
+       
+       , handlePackPragma
+       
+       , childAttributes
+
+       ) where
+
+import IDLSyn
+import qualified CoreIDL as Core (Expr(..),Type(..))
+import DsMonad
+import BasicTypes
+import Literal
+import Int
+import Word    ( Word16 )
+import Bits
+import Utils   ( notNull )
+import List   ( isPrefixOf, find )
+import Char   ( isDigit, isAlpha, isSpace )
+import Opts   ( optUnwrapSingletonStructs, optOnlyRemoveDefns )
+import Digraph
+import Maybe
+import Monad
+import PpIDLSyn
+import Env
+
+{-
+Only used by idlToCoreTy, idlToCoreExpr
+import CoreUtils ( mkId, iUnknownTy, iDispatchTy, bstrTy )
+import Utils     ( mapFromMb )
+-}
+
+\end{code}
+
+\begin{code}
+mkFunId :: Id -> [Param] -> Id
+mkFunId f ps = 
+  case findCC f of
+--    (mb_cc, FunId i' _ _ ) -> FunId i' mb_cc ps
+    (mb_cc, i')            -> FunId i' mb_cc ps
+ where
+  findCC i@Id{}        = (Nothing, i)
+  findCC (AttrId as i) = 
+     case findCC i of
+       (mb_cc, i') -> (mb_cc, AttrId as i')
+  findCC i@ArrayId{} = (Nothing, i)
+  findCC i@FunId{}   = (Nothing, i)
+  findCC (BitFieldId _ i) = findCC i
+  findCC (Pointed qs i)  = 
+     case findCC i of
+       (mb_cc, i') -> (mb_cc, Pointed qs i')
+  findCC (CConvId cc i) = (Just cc, i')
+    where
+      i' = ripOffCC i
+      
+  ripOffCC (CConvId _ ci) = ripOffCC ci
+  ripOffCC i	          = snd (findCC i)
+
+-- push pointedness and callconvs inwards.
+massageId :: Id -> Id
+massageId = mkMethodId
+      
+\end{code}
+
+@mkMethodId@ pushes the @FunId@ outwards and @PointedId@s
+inwards - need to do this in order to desugar method signatures
+correctly.
+
+\begin{code}
+mkMethodId :: Id -> Id
+mkMethodId m_id = go m_id Nothing []
+ where
+   go (Pointed qs i) cacc qacc     = go i cacc (qs:qacc)
+   go (CConvId c i)  cacc qacc     = go i (cacc `mplus` Just c) qacc
+   go (AttrId _  i)  cacc qacc     = go i cacc qacc
+   go (BitFieldId _ i) cacc qacc   = go i cacc qacc
+   go (FunId i mb_cc ps) cacc qacc = 
+   	  FunId (foldr Pointed i (reverse qacc))
+		(cacc `mplus` mb_cc)
+		ps
+
+   go _ _ _ = m_id -- in vain, just return orig id.
+
+\end{code}
+
+When parsing, attributes such as pointer indirection, calling convention etc.
+gets associated with the Id of a method/field rather than the (result) type.
+@transferPointedness@ shifts it over to the type.
+
+\begin{code}
+transferPointedness :: Id -> Type -> Type
+transferPointedness pid ty =
+  case pid of
+    Pointed _ i   -> transferPointedness i (TyPointer ty)
+    ArrayId i e   -> transferPointedness i (TyArray ty e)
+    FunId i cc ps -> transferPointedness i (TyFun cc ty ps)
+    AttrId _ i    -> transferPointedness i ty
+    _		  -> ty
+
+\end{code}
+
+
+\begin{code}
+iName :: Id -> Name
+iName (Id s)        = s
+iName (ArrayId i _) = iName i
+iName (Pointed _ i) = iName i
+iName (CConvId _ i) = iName i
+iName (AttrId _ i)  = iName i
+iName (BitFieldId _ i) = iName i
+iName (FunId i _ _) = iName i
+
+removeIdAttrs :: Id -> Id
+removeIdAttrs (AttrId _ i) = removeIdAttrs i
+removeIdAttrs i = i
+
+idAttrs :: Id -> [Attribute]
+idAttrs (AttrId as i) = as ++ idAttrs i
+idAttrs _ = []
+
+noAttrs :: [Attribute]
+noAttrs = []
+\end{code}
+
+Various @IDLSyn.Type@ predicates:
+
+\begin{code}
+isUnpointedId :: Id -> Bool
+isUnpointedId Pointed{} = False
+isUnpointedId ArrayId{} = False
+isUnpointedId (AttrId _ i) = isUnpointedId i
+isUnpointedId _         = True
+
+isConstructedTy :: Type -> Bool
+isConstructedTy (TyStruct _ [(_,_,[_])] _) = not optUnwrapSingletonStructs
+isConstructedTy TyStruct{}   = True
+isConstructedTy TyEnum{}     = True
+isConstructedTy TyUnion{}    = True
+isConstructedTy TyUnionNon{} = True
+isConstructedTy TyCUnion{}   = True
+isConstructedTy _            = False
+
+isEmptyStructTy :: Type -> Bool
+isEmptyStructTy (TyStruct _ [] _) = True
+isEmptyStructTy _		  = False
+
+isAnonTy :: Type -> Bool
+isAnonTy (TyName nm _) = "__IHC_TAG" `isPrefixOf` nm
+isAnonTy _	  = False
+
+isFunTy :: Type -> Bool
+isFunTy TyFun{} = True
+isFunTy _	= False
+
+isCompleteTy :: Type -> Bool
+isCompleteTy ty = 
+   case ty of
+    TyStruct _ ls _    -> notNull ls
+    TyEnum _ ls        -> notNull ls
+    TyUnion _ _ _ _ ls -> notNull ls
+    TyUnionNon _ ls    -> notNull ls
+    TyCUnion _ ls _    -> notNull ls
+    _		       -> error "isCompleteTy"
+
+isReferenceTy :: Type -> Bool
+isReferenceTy = not.isCompleteTy
+
+mkReferenceTy :: Type -> Type
+mkReferenceTy ty = 
+   case ty of
+    TyStruct tg _ _     -> TyStruct tg [] Nothing
+    TyEnum tg _         -> TyEnum tg []
+    TyUnion tg t i _ _  -> TyUnion tg t i Nothing []
+    TyUnionNon tg _     -> TyUnionNon tg []
+    TyCUnion tg _ _     -> TyCUnion tg [] Nothing
+    _                   -> error "IDLUtils.mkReferenceTy: expected a constructed ty"
+                     
+getTyTag :: String -> Type -> String
+getTyTag def (TyEnum mb_tag _)     = fromMaybe def (fmap iName mb_tag)
+getTyTag def (TyStruct mb_tag _ _) = fromMaybe def (fmap iName mb_tag)
+getTyTag def (TyUnion mb_tag _ _ _ _) = fromMaybe def (fmap iName mb_tag)
+getTyTag def (TyUnionNon mb_tag _)    = fromMaybe def (fmap iName mb_tag)
+getTyTag def (TyCUnion mb_tag _ _)    = fromMaybe def (fmap iName mb_tag)
+getTyTag _   (TyName n  _)  = n
+getTyTag def (TyPointer t)  = getTyTag def t
+getTyTag _   t               
+  = error ("IDLUtils.getTyTag: unexpected type: " ++ showIDL (ppType t))
+
+-- When generating type libraries, MIDL likes
+-- to flatten typedefs to constructed types, i.e.,
+--  typedef enum { a } b; 
+-- is turned into
+--  typedef enum { a } __MIDL___MIDL__aaaa;
+--  typedef [public] __MIDL___MIDL__aaaa b;
+-- 
+-- We try to shorten out these silly names in the
+-- desugarer.
+isMIDLishTy :: Type -> Bool
+isMIDLishTy ty =
+  case ty of
+    TyName nm _ -> isMIDLishNm nm
+    _	        -> False
+
+isMIDLishId :: Id -> Bool
+isMIDLishId (Id s) = isMIDLishNm s
+isMIDLishId _      = False
+
+isMIDLishNm :: String -> Bool
+isMIDLishNm nm = "MIDL___MIDL__" `isPrefixOf` nm'
+ where
+   -- Note: we have deleted the leading underscores by now
+   --  (the desugarer does this.)
+   nm' =
+    case nm of
+     '_':'_':xs -> xs
+     _ -> nm
+                     
+\end{code}
+
+\begin{code}
+tyTag :: Type -> String
+tyTag (TyStruct   (Just i) _ _)     = iName i
+tyTag (TyEnum     (Just i) _)       = iName i
+tyTag (TyUnion    (Just i) _ _ _ _) = iName i
+tyTag (TyUnionNon (Just i) _)       = iName i
+tyTag (TyCUnion   (Just i) _ _)     = iName i
+tyTag (TyName nm _)		    = nm
+tyTag _				    = ""
+
+withTyTag :: String -> Type -> Type
+withTyTag tg ty = 
+  case ty of
+    TyStruct Nothing a b -> TyStruct tag a b
+    TyEnum   Nothing a   -> TyEnum   tag a
+    TyUnion  Nothing a b c d -> TyUnion tag a b c d
+    TyUnionNon Nothing a  -> TyUnionNon tag a
+    TyCUnion Nothing a b  -> TyCUnion tag a b
+    _ -> ty
+ where
+  tag = Just (Id tg)
+
+-- left most type qualifier 'wins'.
+getTyQual :: Type -> ([Qualifier], Type)
+getTyQual (TyApply (TyQualifier q) t) = ([q], t') 
+  where
+   -- continue spinning, dropping the type quals we're
+   -- going to ignore.
+   (_, t') = getTyQual t
+getTyQual t = ([],t)
+\end{code}
+
+\begin{code}
+isVoidTyDef :: Type -> [Id] -> Bool
+isVoidTyDef TyVoid [Id _] = True
+isVoidTyDef _      _      = False
+\end{code}
+
+When filling in values for the enum tags, we have to reduce the expressions
+for the tags that do have a value attached to them.
+
+The name to value mapping passed is the mapping for constants.
+
+\begin{code}
+reduceExpr :: (Type -> DsM Core.Type) -> Expr -> DsM (Either Int32 Core.Expr)
+reduceExpr redType expr =
+ case expr of
+   Binary op e1 e2 -> do
+     i1 <- reduceExpr redType e1
+     i2 <- reduceExpr redType e2
+     return (binop_m op i1 i2)
+   Cond e1 e2 e3 -> do
+     i1 <- reduceExpr redType e1
+     i2 <- reduceExpr redType e2
+     i3 <- reduceExpr redType e3
+     return (cond_m i1 i2 i3)
+   Unary op e -> do
+     i <- reduceExpr redType e
+     return (unop_m op i)
+   Var nm -> do
+     res <- lookupConst nm
+     case res of
+       Nothing -> return (Right (Core.Var nm))
+       Just v  -> return v
+   Lit l  -> return (Left (reduceLit l))
+   Cast t e -> do
+      res <- reduceExpr redType e
+      t'  <- redType t
+      case res of
+        Left  i  -> return (Left i)  -- ToDo: perform cast operation on the result.
+	Right e' -> return (Right (Core.Cast t' e'))
+   Sizeof t -> do
+      t' <- redType t
+      return (Right (Core.Sizeof t'))
+
+reduceLit :: Literal -> Int32
+reduceLit l =
+ case l of
+   IntegerLit (ILit _ i) -> fromInteger i
+   _ -> error ("reduceLit(" ++ show l ++ "): no can do.")
+
+binop_m :: BinaryOp 
+        -> Either Int32 Core.Expr
+	-> Either Int32 Core.Expr
+	-> Either Int32 Core.Expr
+binop_m op (Left i1) (Left i2)   = Left (binop op i1 i2)
+binop_m op e1 e2  = Right (Core.Binary op (toExpr e1) (toExpr e2))
+
+binop :: BinaryOp -> Int32 -> Int32 -> Int32
+binop op i1 i2 =
+ case op of
+   Add -> i1 + i2
+   Sub -> i1 - i2
+   Div -> i1 `div` i2
+   Mod -> i1 `mod` i2
+   Mul -> i1 * i2
+   And -> i1 .&. i2
+   Or  -> i1 .|. i2
+   Xor -> i1 `xor` i2
+   Shift L -> shiftL i1 (fromIntegral i2)
+   Shift R -> shiftR i1 (fromIntegral i2)
+   _       -> error ("binop: unexpected " ++ show op)
+
+cond_m :: Either Int32 Core.Expr -> Either Int32 Core.Expr 
+       -> Either Int32 Core.Expr -> Either Int32 Core.Expr 
+cond_m (Left i1) (Left i2) (Left i3) = Left (cond i1 i2 i3)
+cond_m e1 e2 e3 = Right (Core.Cond (toExpr e1) (toExpr e2) (toExpr e3))
+
+toExpr :: Either Int32 Core.Expr -> Core.Expr
+toExpr (Right e) = e
+toExpr (Left  i) = Core.Lit (IntegerLit (ILit 10 (toInteger i)))
+
+cond :: Int32 -> Int32 -> Int32 -> Int32
+cond 0 x _ = x
+cond _ _ y = y
+
+unop_m :: UnaryOp -> Either Int32 Core.Expr -> Either Int32 Core.Expr
+unop_m op (Left i1)  = Left  (unop op i1)
+unop_m op (Right e1) = Right (Core.Unary op e1)
+
+unop :: UnaryOp -> Int32 -> Int32
+unop Minus i = negate i
+unop Plus  i = i
+unop Not   i = complement i
+unop o     _ = error ("unop: unexpected " ++ show o)
+\end{code}
+
+
+\begin{code}
+isLeafDefn :: Defn -> Bool
+isLeafDefn TypeDecl{}  = True
+isLeafDefn Typedef{}   = True
+isLeafDefn Operation{} = True
+isLeafDefn Constant{}  = True
+isLeafDefn _	       = False
+
+\end{code}
+
+begin{code}
+idlToCoreTy :: Type -> Core.Type
+idlToCoreTy ty = 
+ case ty of
+  TyInteger sz        -> Core.Integer sz True
+  TyFloat sz          -> Core.Float sz
+  TyChar              -> Core.Char False
+  TyWChar             -> Core.WChar
+  TyBool              -> Core.Bool
+  TyOctet             -> Core.Octet
+  TyAny               -> Core.Any
+  TyObject            -> Core.Object
+  TyBString           -> bstrTy
+  TyVoid              -> Core.Void
+  TyName nm Nothing   -> Core.Name nm nm Nothing Nothing Nothing Nothing
+  TyName nm (Just t)  -> Core.Name nm nm Nothing Nothing (Just (idlToCoreTy t)) Nothing
+  TyIface "IUnknown"  -> iUnknownTy
+  TyIface "IDispatch" -> iDispatchTy
+  TyIface nm          -> Core.Iface nm Nothing nm [] False []
+  TyPointer t         -> Core.Pointer Ptr False (idlToCoreTy t)
+--  TyFixed mb e i    -> Core.Fixed (idlToCoreExpr e) i
+  TyArray t es        -> Core.Array (idlToCoreTy t) (map idlToCoreExpr es)
+  TyApply (TySigned s) (TyInteger sz) -> Core.Integer sz s
+  TyApply (TySigned s) TyChar -> Core.Char s
+  TyApply (TySigned s) _ -> Core.Integer Long s
+  TySigned s ->  Core.Integer Long s
+  TyApply (TyQualifier _) t -> idlToCoreTy t
+  TyApply t (TyQualifier _) -> idlToCoreTy t
+  TyString mb_expr     ->
+     let core_expr = mapFromMb Nothing
+			       (Just . idlToCoreExpr) 
+			       mb_expr
+     in
+     Core.String (Core.Char False) False core_expr
+  TyWString mb_expr    ->
+     let 
+       core_expr = mapFromMb Nothing
+			     (Just . idlToCoreExpr) 
+			     mb_expr
+     in
+     Core.WString False core_expr
+  TySequence t mb_expr ->
+     let
+       core_ty   = idlToCoreTy t
+       core_expr = mapFromMb Nothing
+       			     (Just . idlToCoreExpr)
+			     mb_expr
+     in
+     Core.Sequence core_ty core_expr Nothing
+  TyApply (TyQualifier _) t -> idlToCoreTy t
+
+  TyEnum (Just (Id nm)) _     -> Core.Enum (mkId nm nm Nothing []) Unclassified []
+  TyStruct (Just (Id nm)) _ mb_pack -> Core.Struct (mkId nm nm Nothing []) [] mb_pack
+  TyUnion (Just (Id nm1)) t 
+              (Id nm2) (Just (Id nm3)) _-> 
+	Core.Union (mkId nm1 nm1 Nothing []) (idlToCoreTy t)
+		   (mkId nm2 nm2 Nothing []) (mkId nm3 nm3 Nothing []) []
+  TyUnionNon (Just (Id nm1)) _ -> 
+        Core.UnionNon (mkId nm1 nm1 Nothing []) []
+  TyCUnion (Just (Id nm)) _ mb_pack ->
+	Core.CUnion (mkId nm nm Nothing []) [] mb_pack
+
+end{code}
+
+Conversion an IDLSyn expression tree into a CoreIDL one - 
+a candidate for polytypic treatment.
+
+begin{code}
+idlToCoreExpr :: Expr -> Core.Expr
+idlToCoreExpr e =
+ case e of
+  Binary bop e1 e2 -> Core.Binary bop (idlToCoreExpr e1)
+  				      (idlToCoreExpr e2)
+  Cond e1 e2 e3 -> Core.Cond (idlToCoreExpr e1)
+  			     (idlToCoreExpr e2)
+			     (idlToCoreExpr e3)
+  Unary op e1 -> Core.Unary op (idlToCoreExpr e1)
+  Var nm      -> Core.Var nm
+  Lit l       -> Core.Lit l
+  Cast t e1   -> Core.Cast (idlToCoreTy t) (idlToCoreExpr e1)
+  Sizeof t    -> Core.Sizeof (idlToCoreTy t)
+end{code}
+
+Common attributes:
+
+\begin{code}
+simpleAttr :: String -> Attribute
+simpleAttr nm = Attrib (Id nm) []
+
+retValAttribute, lcidAttribute, optionalAttribute :: Attribute
+retValAttribute		= simpleAttr "retval"
+lcidAttribute	        = simpleAttr "lcid"
+optionalAttribute       = simpleAttr "optional"
+
+controlAttribute, restrictedAttribute, hiddenAttribute :: Attribute
+controlAttribute	= simpleAttr "control"
+restrictedAttribute	= simpleAttr "restricted"
+hiddenAttribute	        = simpleAttr "hidden"
+
+defaultAttribute :: Maybe Literal -> Maybe Attribute
+defaultAttribute Nothing  = Nothing
+defaultAttribute (Just x) = Just (Attrib (Id "defaultvalue") [AttrLit x])
+
+versionAttr :: Word16 -> Word16 -> Maybe Attribute
+versionAttr maj mino    = toMaybe (\ _ -> maj /=0 || mino /=0)
+				  (Attrib (Id "version") [AttrLit (LitLit ((show maj) ++'.':show mino))])
+				  undefined
+
+helpStringAttr :: String -> Maybe Attribute
+helpStringAttr	s
+  = toMaybe notNull (Attrib (Id "helpstring") [AttrLit (StringLit s)]) s
+
+helpContextAttr :: Integer -> Maybe Attribute
+helpContextAttr c 
+  = toMaybe (/=0)   (Attrib (Id "helpcontext") [AttrLit (IntegerLit (ILit 16 c))]) c
+helpFileAttr :: String -> Maybe Attribute
+helpFileAttr hfile
+  = toMaybe notNull (Attrib (Id "helpfile") [AttrLit (StringLit hfile)]) hfile
+
+helpStringDllAttr :: String -> Maybe Attribute
+helpStringDllAttr dll
+  = toMaybe notNull (Attrib (Id "helpstringdll")
+  			    [AttrLit (StringLit dll)]) dll
+
+helpStringCtxtAttr :: Integer -> Maybe Attribute
+helpStringCtxtAttr hc   = 
+   toMaybe (/=0) (Attrib (Id "helpstringcontext")
+   			 [AttrLit (IntegerLit (ILit 16 hc))]) hc
+
+lcidvalAttribute :: Integer -> Maybe Attribute
+lcidvalAttribute lc     = 
+   toMaybe (/=0) (Attrib (Id "lcid") [AttrLit (IntegerLit (ILit 10 lc))]) lc
+
+toMaybe :: (a -> Bool) -> b -> a -> Maybe b
+toMaybe predic res mb_val
+  | predic mb_val = Just res
+  | otherwise	  = Nothing
+
+\end{code}
+
+The type-library reader needs to map TLB types to IDL types - 
+here they are:
+
+\begin{code}
+tyWord16, tyWord32, tyWord64 :: Type
+tyWord16  = TyApply (TySigned False) (TyInteger Short)
+tyWord32  = TyApply (TySigned False) (TyInteger Long)
+tyWord64      = TyApply (TySigned False) (TyInteger LongLong)
+
+tyInt16, tyInt32, tyInt64, tyShort, tyInt :: Type
+tyInt16   = tyShort
+tyInt32   = TyApply (TySigned True) (TyInteger Long)
+tyInt64   = TyApply (TySigned True) (TyInteger LongLong)
+tyShort   = TyApply (TySigned True) (TyInteger Short)
+tyInt	      = tyInt32
+
+tyChar, tyByte :: Type
+tyChar	      = TyChar
+tyByte	      = TyOctet
+
+tyAddr, tyVoid :: Type
+tyAddr        = TyPointer TyVoid
+tyVoid        = TyVoid
+
+tyGUID :: Type
+tyGUID       = TyName "GUID" Nothing
+
+tyIUnknown, tyIDispatch :: Type
+tyIDispatch  = TyIface "IDispatch"
+tyIUnknown    = TyIface "IUnknown"
+
+tyVARIANT :: Type
+tyVARIANT    = TyName "VARIANT" Nothing
+
+tySafeArray :: Type -> Type
+tySafeArray t = TySafeArray t
+
+tyCURRENCY :: Type
+tyCURRENCY    = TyName "CURRENCY" Nothing
+tyDATE :: Type
+tyDATE        = TyName "DATE" Nothing
+tyFILETIME :: Type
+tyFILETIME    = TyName "FILETIME" Nothing
+
+tyIStorage, tyIStream :: Type
+tyIStream     = TyIface "IStream"
+tyIStorage    = TyIface "IStorage"
+
+tyVariantBool :: Type
+tyVariantBool = TyName "VARIANT_BOOL" Nothing
+tyHRESULT :: Type
+tyHRESULT     = TyName "HRESULT" Nothing
+
+tyBSTR, tyString, tyWString :: Type
+tyString      = TyString Nothing
+tyWString     = TyWString Nothing
+tyBSTR	      = TyBString
+
+tyFloat, tyDouble :: Type
+tyFloat       = TyFloat Short
+tyDouble      = TyFloat Long
+\end{code}
+
+Order sorting a sequence of definitions.
+
+\begin{code}
+sortDefns :: [Defn] -> [Defn]
+sortDefns ds = map sortDefn ds_sorted
+  where
+     -- compute def & use of the individual decls.
+   ds_depped  = map mkDefnDep ds
+
+     -- compute scc's
+   ds_groups  = stronglyConnComp ds_depped
+   
+   ds_i = filter isImport ds
+
+   isImport (Import _)    = True
+   isImport (ImportLib _) = True
+   isImport (CInclude _)  = True
+   isImport _	          = False
+
+     -- expand the cyclic groups, taking care to leave
+     -- the import statements up front.
+   ds_sorted  = ds_i ++ filter (not.isImport) (concatMap expandGroup ds_groups)
+
+sortDefn :: Defn -> Defn
+sortDefn (Library i ds) = Library i (sortDefns ds)
+sortDefn (Module i ds)  = Module i (sortDefns ds)
+--sortDefn (Import ls)    = Import (map (\ (x,ds) -> (x, sortDefns ds)) ls)
+sortDefn (Attributed x d) = Attributed x (sortDefn d)
+sortDefn x		= x
+
+mkDefnDep :: Defn -> (Defn, String, [String])
+mkDefnDep d = let (def,uses) = getDefUses d in (d,def,uses)
+
+getDefUses :: Defn -> (String,[String])
+getDefUses d = (def, uses)
+  where
+   uses = getUses d
+   def  = getDef d
+
+getDef :: Defn -> String
+getDef d =
+ case d of
+   Typedef _ _ (i:_)        -> iName i
+   Attributed _ d1	    -> getDef d1
+   ExternDecl _ [i]         -> iName i
+   Operation i _ _ _        -> iName i
+   Interface (Id i) _ _     -> i
+   Module (Id i) _          -> i
+   DispInterface (Id i) _ _ -> i
+   CoClass (Id i) _	    -> i
+   Library (Id i) _	    -> i
+   TypeDecl t		    -> tyTag t
+   _			    -> ""
+
+getUses :: Defn -> [String]
+getUses d = 
+  case d of 
+    Typedef ty _ _	  -> getTyUses ty
+    Constant _ _ ty _	  -> getTyUses ty  -- expressions will never, 
+					   -- ever have free variables (in fact, const is a foreign concept
+					   -- to typelibs.)
+    Interface _ is ds	  -> is ++ concatMap getUses ds
+    Module _ ds	          -> concatMap getUses ds
+    DispInterface _ ps ds -> concatMap (\ (_,t, _) -> getTyUses t) ps ++ concatMap getUses ds
+    CoClass _ cs	  -> map (\ (_,Id i,_) -> i) cs
+    Library _ ds	  -> concatMap getUses ds
+    Attributed _ d1	  -> getUses d1
+    TypeDecl t		  -> getTyUses t
+    ExternDecl t _        -> getTyUses t
+    Operation (FunId _ _ ps) r _ _ -> getTyUses r ++ concatMap (\ (Param _ t _) -> getTyUses t) ps
+    _			  -> []
+
+-- Since the types were constructed from type libraries, we can make
+-- a number of simplifying assumptions.
+getTyUses :: Type -> [String]
+getTyUses ty =
+  case ty of
+    TyName  n _     -> [n]
+    TyIface n       -> [n]
+    TySafeArray t   -> getTyUses t
+    TyArray t _     -> getTyUses t
+    TyPointer t     -> getTyUses t
+    TyCUnion _ fs _ -> concatMap (\ (t,_,_) -> getTyUses t) fs
+    TyStruct (Just (Id n)) [] _ -> [n]
+    TyStruct _ fs _ -> concatMap (\ (t,_,_) -> getTyUses t) fs
+    TyEnum (Just (Id n)) []   -> [n]
+    TyApply t1 t2	      -> getTyUses t1 ++ getTyUses t2
+    _			      -> []
+
+expandGroup :: SCC Defn -> [Defn]
+expandGroup (AcyclicSCC d) = [d]
+expandGroup (CyclicSCC ds) = ds'
+  where
+    -- record who was in our group, so that
+    -- we can fight loops later.
+
+   ds_uses = map getDef ds
+   ds'     = forwardDecls ds (go [] ds_uses ds)
+
+   forwardDecls []     cont = cont
+   forwardDecls (a:as) cont = mkForwardDecl a (forwardDecls as cont)
+
+   mkForwardDecl (Attributed _ d) cont = mkForwardDecl d cont
+   mkForwardDecl (Interface i _ _) cont = Forward i : cont
+   mkForwardDecl (DispInterface i _ _) cont = Forward i : cont
+   mkForwardDecl _ cont = cont
+
+   go _   _           [] = []
+   go _   []          _  = []
+   go bef (a:aft) (x:xs) = Attributed as x : go (a:bef) aft xs
+    where
+      as = map (\ ll -> Attrib (Id "depender") [AttrLit (LitLit ll)]) (bef ++ aft)
+
+\end{code}
+
+Sigh - copy of the routine you'll find in CoreUtils, but this
+time over IDLSyn attributes.
+
+\begin{code}
+childAttributes :: [Attribute] -> [Attribute]
+childAttributes as = filter (not.notAggregatableAttribute) as
+
+notAggregatableAttribute :: Attribute -> Bool
+notAggregatableAttribute (Attrib (Id nm) _) = nm `elem` junk_list
+  where
+   junk_list =
+     [ "helpstring"
+     , "helpcontext"
+--     , "pointer_default"
+     , "dllname"
+     , "lcid"
+     , "odl"
+     , "restricted"
+     , "ole"
+     , "uuid"
+     , "object"
+     , "oleautomation"
+     , "hidden"
+     , "version"
+     , "local"
+     , "custom"
+     , "public"
+     , "dual"
+     , "switch_type"
+     , "switch_is"
+     , "depender"
+     , "ty_params"
+     , "jni_interface"
+     , "jni_iface_ty"
+     , "jni_class"
+     , "hs_name"
+     , "hs_import"
+     , "hs_newtype"
+     ]
+notAggregatableAttribute _ = False
+\end{code}
+
+The user can off-line specify which of the defns are (or aren't) of interest.
+@winnowDefn@ is responsible from picking the chaff from the wheat, as it where.
+
+\begin{code}
+winnowDefns :: Env String (Bool,[Attribute]) 
+	    -> [Defn]
+	    -> [Defn]
+winnowDefns wenv ws = reverse $ fst (go wenv "" (reverse ws))
+ where
+   go env _          [] = ([], env)
+   go env prefix (d:ds) =
+     case getDef d of 
+       "" -> let (ds', e) = go env prefix ds in (d:ds', e)
+       nm -> let
+	       res  = lookupEnv env nm `mplus` lookupEnv env (prefix ++ '.':nm)
+	       uses = getUses d
+	       
+		-- for a names that are to be retained, arrange for
+		-- any of its uses to be retained also.
+	       inh_value = (True, [Mode In])
+
+                -- keep the decl iff:
+		--   * it didn't have remove-me flag 
+		--   * it was found in the environment nontheless.
+		--   * we're in remove-only mode.
+	       keep_it = not remove_it && (optOnlyRemoveDefns || isJust res)
+
+	       remove_it =
+	         case res of
+		   Just (flg,ls) -> not flg && null ls 
+		   		-- an asf entry is a 'remove-me' entry iff
+				-- it is of the form "Name=<empty>"
+		   _		 -> False
+
+	       env'
+		| isJust res    =
+		   if remove_it || optOnlyRemoveDefns then
+		      env
+		   else
+		      addListToEnv env (map (\ x -> (x, inh_value)) uses)
+		| otherwise     = env
+		
+	       newPrefix i
+	        | null prefix = iName i
+		| otherwise   = prefix ++ '.':iName i
+	      in
+	      case d of
+	        Attributed as d1 ->
+		    case go env' prefix [d1] of
+		      ([],_)     -> go env' prefix ds
+		      ((x:_), e) -> let 
+		                     (ds', e1) = go e prefix ds
+				    in 
+				    (Attributed as x : ds', e1)
+	        Interface i inhs ms ->
+		    case go env' (newPrefix i) (reverse ms) of
+		      (ms', e) -> let (ds', e1) = go e prefix ds in
+		                  if remove_it || (null ms' && (notNull ms || not keep_it)) then
+				     (ds', e1)
+				  else
+				     (Interface i inhs (reverse ms') : ds', e1)
+	        DispInterface i props ms ->
+		    case go env' (newPrefix i) (reverse ms) of
+		      (ms', e) -> let (ds', e1) = go e prefix ds in
+		                  if remove_it || (null ms' && (notNull ms || not keep_it)) then
+				     (ds', e1)
+				  else
+				     (DispInterface i props (reverse ms') : ds', e1)
+		Library i ls ->
+		    case go env' (newPrefix i) (reverse ls) of
+		      (ls', e) -> let (ds', e1) = go e prefix ds in
+		                  if remove_it || (null ls' && (notNull ls || not keep_it)) then
+				     (ds', e1)
+				  else
+		                     (Library i (reverse ls') : ds', e1)
+		Module i ms ->
+		    case go env' (newPrefix i) (reverse ms) of
+		      (ms', e) -> let (ds', e1) = go e prefix ds in
+		                  if remove_it || (null ms' && (notNull ms || not keep_it)) then
+				     (ds', e1)
+				  else
+		                     (Module i (reverse ms') : ds', e1)
+	        _ -> let (ds', e) = go env' prefix ds in 
+		     if keep_it then
+		        (d:ds', e)
+	             else
+		        (ds', e)
+    
+\end{code}
+
+
+\begin{code}
+exprToName :: Expr -> String
+exprToName e = map (\ x -> if (isAlpha x || isDigit x) then x else '_') 
+                   (showIDL (ppExpr e))
+\end{code}
+
+Gather the type of an expression - unknown 
+
+\begin{code}
+exprType :: Type -> Expr -> Type
+exprType defTy ex = 
+  case ex of 
+     Lit l         -> litType l
+     Cast t _      -> t
+     Sizeof{}      -> TyInteger Natural
+     Var{}         -> defTy
+     Cond _ e1 _   -> exprType defTy e1
+     Binary _ e1 _ -> exprType defTy e1
+     Unary uop e -> 
+       case uop of
+          Deref -> TyPointer (exprType defTy e)
+	  _     -> exprType defTy e
+
+litType :: Literal -> Type
+litType l = 
+  case l of
+    IntegerLit{}  -> TyInteger Natural
+    StringLit{}   -> TyString Nothing
+    TypeConst s   -> TyName s Nothing
+    WStringLit{}  -> TyWString Nothing
+    CharLit{}     -> TyChar
+    WCharLit{}    -> TyWChar
+    FixedPtLit{}  -> TyFixed Nothing
+    FloatingLit{} -> TyFloat Long
+    BooleanLit{}  -> TyBool
+    NullLit{}     -> TyPointer TyVoid
+    GuidLit{}     -> TyName "GUID" Nothing
+    LitLit{}      -> error "litType{LitLit}: can't determine type"
+
+\end{code}
+
+\begin{code}
+toPackedAttrib :: [GNUAttrib] -> Maybe Int
+toPackedAttrib [] = Nothing
+toPackedAttrib ls = 
+   case find (==Packed) ls of
+     Nothing -> Nothing
+     Just _  -> Just 1
+
+toCConvAttrib :: [GNUAttrib] -> (Id -> Id)
+toCConvAttrib [] = id
+toCConvAttrib ls = 
+   case find isCConv ls of
+     Just (CConv cc) -> CConvId cc
+     _               -> id
+ where
+  isCConv CConv{} = True
+  isCConv _	  = False
+
+mkGNUAttrib :: String -> [Expr] -> GNUAttrib
+mkGNUAttrib "packed" _ = Packed
+mkGNUAttrib x        _ = Unsupported x -- record just the name.
+\end{code}
+
+Hidden here because it is pig ugly.
+
+\begin{code}
+handlePackPragma :: String -> DsM ()
+handlePackPragma ('p':'a':'c':'k':xs) = 
+    -- For now, cheap & nasty.
+   case dropWhile isSpace xs of
+     ')':_                     -> pushPack Nothing
+     '(':'p':'u':'s':'h':')':_ -> pushPack (Just Nothing)
+     '(':'p':'o':'p':')':_     -> popPack Nothing
+     '(':'p':'u':'s':'h':',':ys@(y:_) | isAlpha y -> 
+  	let
+	 (nm, rs) = break (\x -> x == ',' || x == ')') ys
+	in
+	case rs of
+	  ')':_ -> pushPack (Just (Just (nm, Nothing)))
+	  ',':rs2 -> 
+	     let
+	      (val, rs3) = break (== ')') rs2
+	     in
+	     case rs3 of
+	       ')':_ -> 
+  	         case reads val of
+	           ((v,_):_) -> pushPack (Just (Just (nm, Just v)))
+		   _ -> return ()
+	       _ -> return ()
+          _ -> return ()
+     '(':'p':'u':'s':'h':',':ys@(y:_) | isDigit y -> 
+	let
+	 (val, rs) = break (== ')') ys
+	in
+	case rs of
+	  ')':_ -> do
+	     case reads val of
+	       ((v,_):_) -> pushPack (Just (Just ("", Just v)))
+	       _         -> return ()
+          _ -> return ()
+     '(':'p':'o':'p':',':ys@(y:_) | isAlpha y -> 
+  	let
+	 (nm, rs) = break (\x -> x == ',' || x == ')') ys
+	in
+	case rs of
+	  ')':_   -> popPack (Just (nm, Nothing))
+	  ',':rs2 -> 
+	     let
+	      (val, rs3) = break (== ')') rs2
+	     in
+	     case rs3 of
+	       ')':_ -> 
+  	         case reads val of
+	           ((v,_):_) -> popPack (Just (nm, Just v))
+		   _ -> return ()
+	       _ -> return ()
+          _ -> return ()
+     '(':'p':'o':'p':',':ys@(y:_) | isDigit y -> 
+	let
+	 (val, rs) = break (== ')') ys
+	in
+	case rs of
+	  ')':_ -> do
+	     case reads val of
+	       ((v,_):_) -> popPack (Just ("", Just v))
+	       _         -> return ()
+          _ -> return ()
+     _ -> return ()
+
+handlePackPragma _ = return ()
+
+\end{code}
+ src/ImportLib.lhs view
@@ -0,0 +1,1354 @@+%
+% 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 "<no entry points>"
+     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}
+ src/JavaProxy.lhs view
@@ -0,0 +1,255 @@+%
+% (c) 1999, sof
+%
+
+From an interface, generate a corresponding Java
+class/interface which allows you to override its
+methods with Haskell implementations of them.
+
+The emitted code currently uses the FunctionPointer
+invocation interface to call from Java into Haskell,
+but will eventually be extended to also emit native
+method declarations.
+
+\begin{code}
+module JavaProxy ( javaProxyGen, prepareDecls ) where
+
+import CoreIDL
+import CoreUtils ( isVoidTy )
+import Attribute
+import BasicTypes
+import Literal
+import PP
+import PpCore ( showCore, ppType )
+import Maybe  ( mapMaybe )
+\end{code}
+
+The generator is simple-minded - spit out a pretty
+printed template of the class/interface - no abstract
+Java syntax, no nothing.
+
+\begin{code}
+javaProxyGen :: Decl -> String
+javaProxyGen (Interface i False _ ds)
+ | is_class =
+   showPPDoc 
+     (emitHeader i <+> char '{' $$
+       vsep (map emitMethod ds) $$
+       emitConstructor i ds     $$
+      text "}")
+     ()
+ where
+  is_class = idAttributes i `hasAttributeWithName` "jni_class"
+
+javaProxyGen _ = ""
+
+type Doc = PPDoc ()
+\end{code}
+
+\begin{code}
+prepareDecls :: [Decl] -> [(String,Decl)]
+prepareDecls [] = []
+prepareDecls (x:xs) = 
+  case x of
+    Typedef{} -> prepareDecls xs
+    Interface{declId=i}  -> (idOrigName i ++ "Proxy", x) : prepareDecls xs
+    Module{declDecls=ys} ->
+      prepareDecls (ys ++ xs)
+    Library{declDecls=ys} ->
+      prepareDecls (ys ++ xs)
+    _ -> prepareDecls xs
+
+\end{code}
+
+
+\begin{code}
+emitHeader :: Id -> Doc
+emitHeader i = 
+  text "public" <+> pp_kind <+> pp_name <+> pp_inherit <+> pp_implements
+ where
+  attrs = idAttributes i
+
+  ifaces_implemented = mapMaybe toNm (filterAttributes attrs ["jni_interface"])
+    where
+     toNm  (Attribute _ [ParamLit (StringLit s)]) = Just s
+     toNm  _					  = Nothing
+
+  is_class = attrs `hasAttributeWithName` "jni_class"
+  
+  pp_name = text ((idOrigName i) ++ "Proxy")
+
+  pp_kind
+   | is_class  = text "class"
+   | otherwise = text "interface"
+   
+  pp_inherit = text "extends " <+> text (idOrigName i)
+
+  pp_implements 
+    | null ifaces_implemented = empty
+    | otherwise = text "implements" <+> 
+                  hsep (punctuate comma (map text ifaces_implemented))
+    
+\end{code}
+
+\begin{code}
+emitMethod :: Decl -> Doc
+emitMethod (Method i _ res ps _)
+  | is_ignorable = empty  
+{-
+  | is_field = 
+    text "public" <+> pp_static <+> 
+      emitType (resultType res) <+>
+    text field_name <> semi
+-}
+  | otherwise = -- a trusty old method
+    text "public" <+> pp_static <+>
+      emitType (resultType res) <+> 
+    text (idOrigName i) <+> ppTuple (zipWith emitParam ps [0..]) $$
+    char '{' $$
+     return_decl <+>
+       castResult (resultType res) 
+       		  (fptr_call <> ppTuple (zipWith emitParamUse ps [0..]))
+		  <> semi $$
+    char '}'
+ where 
+  attrs = idAttributes i
+
+  fptr_call = text ("fptr_"++idOrigName i ++ ".call")
+  
+  return_decl 
+    | isVoidTy (resultType res) = empty
+    | otherwise                 = text "return"
+
+{-
+  field_name =
+    case idOrigName i of
+      'g':'e':'t':'_':xs -> xs
+      ls -> ls
+-}
+   -- Java doesn't have a notion of read-only fields,
+   -- so we simply ignore field setters and only
+   -- generate the Java field decl when seeing the getter.
+   --
+   -- ...Leave out fields for the moment, as we don't have a
+   -- good way of mapping them to a Haskell impl.
+
+  is_ignorable = attrs `hasAttributeWithNames` 
+                       ["jni_set_field", "jni_get_field", "jni_ctor"]
+--  is_field = attrs `hasAttributeWithName` "jni_get_field"
+
+  is_static = attrs `hasAttributeWithName` "jni_static"
+  
+  pp_static 
+   | is_static = text "static"
+   | otherwise = empty
+
+emitMethod _ = empty
+
+\end{code}
+
+\begin{code}
+emitType :: Type -> Doc
+emitType ty = 
+  case ty of
+    Integer Short _     -> text "short"
+    Integer Long  _     -> text "long"
+    Integer LongLong  _ -> text "long"
+    Integer Natural _   -> text "int"
+    Float Short -> text "float"
+    Float Long  -> text "double"
+    Char _      -> text "char"
+    Bool        -> text "boolean"
+    Octet       -> text "byte"
+    Object      -> text "java.lang.Object"
+    String{}    -> text "java.lang.String"
+    Name _ _ _ _ (Just t) _ -> emitType t
+    Pointer _ _ t -> emitType t
+    Array t []  -> emitType t <> text "[]"
+    Void        -> text "void"
+    Iface _ _ o _ _ _ -> text o
+    _ -> error ("emitType: unknown type " ++ showCore (ppType ty))
+
+\end{code}
+
+\begin{code}
+emitParam :: Param -> Int -> Doc
+emitParam p idx = emitType (paramType p) <+> text ("arg"++show idx)
+\end{code}
+
+If the parameter is of an unboxed type, box it up before invoking
+@call@
+
+\begin{code}
+emitParamUse :: Param -> Int -> Doc
+emitParamUse p idx =  boxValue (paramType p) (text ("arg"++show idx))
+\end{code}
+
+\begin{code}
+boxValue :: Type -> Doc -> Doc
+boxValue ty d = 
+ case ty of
+    Integer _ _ -> text "new Integer" <> parens d
+    Float Short -> text "new Float" <> parens d
+    Float Long  -> text "new Double" <> parens d
+    Char _      -> text "new Character" <> parens d
+    Bool        -> text "new Boolean" <> parens d
+    Octet       -> text "new Byte" <> parens d
+    Object      -> d
+    String{}    -> d
+    Name _ _ _ _ (Just t) _ -> boxValue t d
+    Pointer _ _ t -> boxValue t d
+    Array _ []  -> d
+    Iface{}     -> d
+    _ -> error ("boxValue: unknown type " ++ showCore (ppType ty))
+
+\end{code}
+
+\begin{code}
+castResult :: Type -> Doc -> Doc
+castResult t d = 
+  case t of
+    Integer _ _ -> parens (text "Integer") <> d <> text ".value"
+    Float Short -> parens (text "Float") <> d <> text ".floatValue"
+    Float Long  -> parens (text "Double") <> d <> text ".doubleValue"
+    Char _      -> parens (text "Character") <> d <> text ".value"
+    Bool        -> parens (text "Character") <> d <> text ".booleanValue"
+    Octet       -> parens (text "Character") <> d <> text ".byteValue"
+    Object      -> d
+    String{}    -> parens (text "String") <> d
+    Name _ _ _ _ (Just ty) _ -> castResult ty d
+    Pointer _ _ ty -> castResult ty d
+    Array ty []  -> parens (castResult ty (text "[]" <> d)) -- won't work.
+    Iface _ _ o _ _ _ -> parens (text o) <> d
+    Void -> d
+    _ -> error ("castResult: unknown type " ++ showCore (ppType t))
+  
+\end{code}
+
+\begin{code}
+emitConstructor :: Id -> [Decl] -> Doc
+emitConstructor i ds = 
+  vsep (map mkMethodPtr ms) $$
+  text "public" <+> text (idOrigName i ++ "Proxy") <> 
+    ppTuple (zipWith (\ x _ -> text ("FunctionPtr arg" ++ show x))
+    		     idxs
+		     ms) $$
+    char '{' $$
+    vsep (zipWith assignFptr idxs ms) $$
+    char '}'
+ where
+  ms = filter isMethod ds
+
+  idxs = [(0::Int)..]
+
+  assignFptr idx m = 
+    functionPtrName m <+> equals <+> text ("arg"++show idx) <> semi
+     
+  functionPtrName d = text ("fptr_" ++ idOrigName (declId d))
+
+   -- should qualify FunctionPtr with its package name.
+  mkMethodPtr d = 
+     text "private FunctionPtr" <+> functionPtrName d <> semi
+
+  isMethod d = not (idAttributes (declId d) `hasAttributeWithNames` 
+  		    ["jni_set_field", "jni_get_field", "jni_ctor"])
+\end{code}
+ src/Lex.lhs view
@@ -0,0 +1,476 @@+%
+% (c) 1998-99, sof
+%
+
+A lexer for MS & OMG IDLs
+
+\begin{code}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Lex 
+        ( 
+ 	  lexIDL    -- :: (IDLToken -> LexM a) -> LexM a
+	) where
+
+import LexM
+import Char
+import Numeric
+import IDLToken
+import List ( isPrefixOf )
+import Literal
+import BasicTypes
+import Utils ( deEscapeString, notNull )
+import SrcLoc
+import Opts ( optIncludeAsImport, optExcludeSysIncludes )
+
+\end{code}
+
+\begin{code}
+lexIDL :: (IDLToken -> LexM a) -> LexM a
+lexIDL cont = do
+ eof <- isEOF
+ if eof
+   then cont T_eof
+   else do
+    c <- getNextChar
+    case c of
+     ' '  -> lexIDL cont
+     '\t' -> lexIDL cont
+     '\v' -> lexIDL cont
+     '\b' -> lexIDL cont
+     '\r' -> lexIDL cont
+     '\f' -> lexIDL cont
+     '\n' -> incLineNo (lexIDL cont)
+     '/'  -> do
+       c1 <- getNextChar
+       case c1 of
+         '/' -> lex_oneline_comment cont
+         '*' -> lex_nested_comment cont (1::Int){-one seen-}
+	 _ -> do
+	   putBackChar c1
+	   cont T_div
+     '(' -> cont T_oparen
+     ')' -> cont T_cparen
+     '{' -> cont T_ocurly
+     '}' -> cont T_ccurly
+     '[' -> cont T_osquare
+     ']' -> cont T_csquare
+     ',' -> cont T_comma
+     '.' -> do
+       c1 <- getNextChar
+       case c1 of
+        '.' -> do
+	  c2 <- getNextChar
+	  case c2 of
+	   '.' -> cont T_dotdotdot
+	   _   -> do
+             putBackChar c1
+             putBackChar c2
+	     cont T_dot
+	_ -> do
+	  putBackChar c1
+	  cont T_dot
+     ';' -> cont T_semi
+     ':' -> do
+       c1 <- getNextChar
+       case c1 of
+          ':' -> cont T_dcolon
+	  _   -> putBackChar c1 >> cont T_colon
+     'L'  -> do
+        c1 <- getNextChar
+	case c1 of
+	  '\"' -> lex_string (\ (T_string_lit ls) -> cont (T_literal (WStringLit ls)))
+	  _    -> putBackChar c1 >> start_lex_id 'L' cont
+
+     '\"' -> lex_string cont -- matching "
+     '\'' -> lex_char cont
+     '='  -> do
+	  c1 <- getNextChar
+          case c1 of
+	    '=' -> cont T_eqeq
+	    _   -> putBackChar c1 >> cont T_equal
+     '!'  -> do
+	  c1 <- getNextChar
+          case c1 of
+	    '=' -> cont T_neq
+	    _   -> putBackChar c1 >> cont T_negate
+     '+'  -> cont T_plus
+     '-'  -> cont T_minus
+     '?'  -> cont T_question
+     '<'  -> do
+	  c1 <- getNextChar
+          case c1 of
+            '<' -> cont (T_shift L)
+	    '=' -> cont T_le
+	    _   -> putBackChar c1 >> cont T_lt
+     '>'  -> do 
+	  c1 <- getNextChar
+          case c1 of
+	    '>' -> cont (T_shift R)
+	    '=' -> cont T_ge
+            _   -> putBackChar c1 >> cont T_gt
+     '|'  -> do
+	  c1 <- getNextChar
+          case c1 of
+	    '|' -> cont T_rel_or
+            _   -> putBackChar c1 >> cont T_or
+     '^'  -> cont T_xor
+     '&'  -> do
+	  c1 <- getNextChar
+          case c1 of
+	    '&' -> cont T_rel_and
+            _   -> putBackChar c1 >> cont T_and
+     '*'  -> cont T_times
+     '%'  -> cont T_mod
+     '~'  -> cont T_not
+     '#'  -> do 
+       -- I'm delaying the decision on whether #pragma lines should 
+       -- be parsed or not. For the moment, we'll just chop off everything
+       -- after #pragma.
+       cs1 <- getStream
+       let cs2 = dropWhile isSpace cs1
+       if "define" `isPrefixOf` cs2 then
+          setStream (drop (6::Int) cs2) >> cont T_hdefine
+        else if "pragma" `isPrefixOf` cs2 then
+	  case span (/='\n') (drop (6::Int){-length of "pragma"-} cs2) of
+	    (prag,[]) -> do
+	       setStream []
+	       cont (T_pragma prag)
+	    (prag,_:cs3) -> do
+	       setStream cs3
+	       cont (T_pragma prag)
+        else if ("line" `isPrefixOf` cs2) || (notNull cs1 && isSpace (head cs1)) then
+	  let
+	    cs1_no_line = dropWhile (not.isDigit) cs1
+	  in
+	    -- munge, munge - get at the line and loc.
+	  case (reads cs1_no_line) of 
+	    ((ln,rs):_) -> 
+	       case (reads (dropWhile isSpace rs)) of
+	        ((fn,rs1):_) -> do
+		     -- drop any trailing info (such as flags)..
+		    let (flags, rs2) = break (=='\n') rs1
+		    setStream rs2
+		    sl  <- getSrcLoc 
+		    osl <- getOrigSrcLoc
+		    let f   = modSrcLoc sl
+		        ofn = modSrcLoc osl
+		        in_system   = '3' `elem` flags
+			at_end      = '2' `elem` flags
+
+		    flg <- getSystemContextFlag
+                    inSystemContext in_system  $ do
+		    setSrcLoc (mkSrcLoc fn ln) $
+		      if (optIncludeAsImport && at_end) then
+		         cont T_include_end
+		      else if (optExcludeSysIncludes && at_end && (flg || ofn == fn)) then
+			  -- emit end marker if we're leaving a system context
+			  -- (or name of source module.)
+		         cont T_include_end
+		      else if (optExcludeSysIncludes && not at_end && (in_system || ofn == fn) && f /= fn) then
+		          -- emit start marker if we're entering a system context
+			  -- (or name of source module.)
+		         cont (T_include_start fn)
+		      else if (not optIncludeAsImport || optExcludeSysIncludes || f == fn) then
+		         lexIDL cont -- nothing new.
+		      else 
+		         cont (T_include_start fn)
+	        _ -> do
+	            sloc <- getSrcLoc
+	            cont (T_unknown (sloc,c:cs1))
+	    _ -> do
+	       sloc <- getSrcLoc
+	       cont (T_unknown (sloc,c:cs1))
+         else do
+	  sloc <- getSrcLoc
+	  cont (T_unknown (sloc,c:cs1))
+     x    -> start_lex_id x cont
+
+start_lex_id :: Char -> (IDLToken -> LexM a) -> LexM a
+start_lex_id c cont = do
+       putBackChar c
+       if isDigit c 
+          then lex_num cont
+          else if isHexDigit c
+	       then lex_guid' cont
+	       else lex_id cont
+
+{-
+spool_on :: String -> [Char] -> [Char]
+spool_on s []     = []
+spool_on s ('\n':'#':xs) = 
+   case dropWhile isSpace (dropWhile isDigit (dropWhile isSpace xs)) of
+     ('"':xs1) | s `isPrefixOf` xs1 -> dropWhile (/= '\n') xs1 -- matching '"'
+     xs            -> spool_on s xs
+spool_on s (x:xs) = spool_on s xs 
+-}
+
+lex_oneline_comment :: (IDLToken -> LexM a) -> LexM a
+lex_oneline_comment cont = do
+  cs <- getStream
+  case dropWhile (/='\n') cs of
+    []     -> setStream [] >> incLineNo (lexIDL cont)
+    (_:xs) -> setStream xs >> incLineNo (lexIDL cont)
+
+lex_nested_comment :: (IDLToken -> LexM a) -> Int -> LexM a
+lex_nested_comment cont count = do
+  cs <- getStream
+  case dropWhile (\ x -> x /='/' && x /= '*' && x /= '\n') cs of
+    []           -> do
+       setStream []
+       lexIDL cont
+    ('\n':cs1)   -> do
+       setStream cs1
+       incLineNo (lex_nested_comment cont count)
+    ('/':'*':cs1) -> do
+       setStream cs1
+       lex_nested_comment cont (count+1)
+    ('*':'/':cs1) -> do
+       setStream cs1
+       if count == 1 
+	then lexIDL cont
+	else lex_nested_comment cont (count-1)
+    (_:cs1)     -> do
+       setStream cs1
+       lex_nested_comment cont count
+
+lex_num :: (IDLToken -> LexM a) -> LexM a
+lex_num cont = do
+  cs <- getStream
+  case cs of
+    '0':'x':cs1 -> 
+     case readHex cs1 of
+       [(i,cs2)] -> setStream (removeL cs2) >> cont (T_literal (IntegerLit (ILit 16 i)))
+       _         -> getSrcLoc >>= \ sc -> cont (T_unknown (sc,cs))
+    '0':cs1 ->
+      case readOct cs1 of
+       [(i,cs2)] -> 
+           case cs2 of
+  	     '-':cs3              -> try_lex_guid cs3
+             c:cs3 | isHexDigit c -> 
+                   case dropWhile (isHexDigit) cs3 of
+		     '-':cs4 -> try_lex_guid cs4
+		     _ -> do
+		        -- or should that be an error ?
+		       setStream cs2
+		       cont (T_literal (IntegerLit (ILit 8 i)))
+             _ -> do
+	       setStream (removeL cs2)
+	       cont (T_literal (IntegerLit (ILit 8 i)))
+            where
+              -- this may just be the start of a GUID.
+	      try_lex_guid cs3 = 
+               case lex_guid (takeWhile (isHexDigit) cs) cs3 of
+                 Nothing         -> do
+		    setStream (removeL cs2)
+		    cont (T_literal (IntegerLit (ILit 8 i)))
+	         Just (guid,cs4) -> do
+		    setStream cs4
+		    cont (T_literal (GuidLit guid))
+       _ ->
+        -- this is a mess.
+	let (as, bs) = span (isHexDigit) cs in
+	case bs of
+	  '-':bs1 -> 
+	    case lex_guid as bs1 of
+	      Nothing -> do
+ 	             sloc <- getSrcLoc
+	             cont (T_unknown (sloc, cs))
+	      Just (guid,cs2) -> do
+		     setStream cs2
+		     cont (T_literal (GuidLit guid))
+	  _ ->
+	    case reads cs of
+              [(i,cs2)] -> do
+	        setStream (removeL cs2)
+	        cont (T_literal (IntegerLit (ILit 10 i)))
+              _ ->
+                case reads cs of
+                  [(d,cs2)] -> do
+	            setStream cs2 
+		    let rs = takeWhile (\ x -> isDigit x || x == '.') cs
+		    cont (T_literal (FloatingLit (rs,d)))
+                  _ -> do
+                    sloc <- getSrcLoc
+                    cont (T_unknown (sloc, cs))
+
+    _ ->	     	      
+        -- this is a mess.
+	let (as, bs) = span (isHexDigit) cs in
+	case bs of
+	  '-':bs1 -> 
+	    case lex_guid as bs1 of
+	      Nothing -> do
+ 	             sloc <- getSrcLoc
+	             cont (T_unknown (sloc, cs))
+	      Just (guid,cs2) -> do
+		     setStream cs2
+		     cont (T_literal (GuidLit guid))
+          _ ->
+            case reads cs of
+             [(i,cs1)] -> do
+                   setStream (removeL cs1)
+		   cont (T_literal (IntegerLit (ILit 10 i)))
+             _ ->
+               case reads cs of
+                 [(d,cs1)] -> do
+		    setStream cs1
+    		    let rs = takeWhile (\ x -> isDigit x || x == '.') cs
+		    cont (T_literal (FloatingLit (rs,d)))
+                 _ -> getSrcLoc >>= \ sc -> cont (T_unknown (sc,cs))
+
+ where
+  removeL ('L':xs) = xs
+  removeL xs       = xs
+
+lex_guid' :: (IDLToken -> LexM a) -> LexM a
+lex_guid' cont = do
+  cs <- getStream
+  case readHex cs of
+     [((_::Int),cs1)] -> 
+       case cs1 of
+        ('-':cs2) -> -- this may just be the start of a GUID.
+            case lex_guid (takeWhile (isHexDigit) cs) cs2 of
+              Nothing         -> lex_id cont
+	      Just (guid,cs3) -> do
+	         setStream cs3
+		 cont (T_literal (GuidLit guid))
+        _ -> lex_id cont
+     _ -> lex_id cont
+
+lex_guid :: String -> String -> Maybe ([String],String)
+lex_guid d1 cs1 =
+ case span (isHexDigit) cs1 of 
+  (d2,'-':cs2) ->
+   case span (isHexDigit) cs2 of 
+    (d3,'-':cs3) ->
+     case span (isHexDigit) cs3 of 
+      (d4,'-':cs4) ->
+       case span (isHexDigit) cs4 of 
+        ([],_)   -> Nothing
+        (d5,cs5) -> Just ([d1,d2,d3,d4,d5],cs5)
+      _            -> Nothing
+    _            -> Nothing
+  _            -> Nothing
+
+lex_id :: (IDLToken -> LexM a) -> LexM a
+lex_id cont = do
+ cs <- getStream
+ case span is_id_char cs of
+   ([],(r:rs)) -> do
+      setStream rs
+      sloc <- getSrcLoc
+      cont (T_unknown (sloc, [r]))
+   (is,rs) -> do
+     t <- lookupSymbol is
+     case t of
+       Just tok@T_safearray ->   -- SIGH.
+           case rs of
+	      ('(':rs2) -> setTok tok >> setStream rs2 >> cont tok
+	      _         -> do
+	          setTok tok
+		  setStream rs
+	          res <- lookupType is  -- check to see whether SAFEARRAY
+					-- is to be considered an ID or a TYPE..
+		  case res of
+		    Nothing  -> cont (T_id "SAFEARRAY")
+		    Just x   -> cont x
+
+       Just (T_include _) -> do
+	    let 
+		-- Sigh, trying to integrate CPP's #include syntax
+		-- into IDLs will lead to trouble (what's the parse of
+		-- "<a>"?) Not unfixable, but let's delay doing so until
+		-- we move to using a lexer generator.
+	        rs'     = dropWhile isSpace rs
+
+	        ((as,bs), wrapper) = 
+		    case rs' of 
+		      '(':xs -> -- ("foo.h") or (foo.h)
+		          (break (==')') xs, id)
+		      '<':xs -> -- <foo.h>
+		          (break (=='>') xs , \ x -> '<':x ++ ">") 
+		      '"':xs ->  -- "foo.h" Don't even think of using double qoutes
+		                 -- in your filenames!
+			  (break (=='"') xs, \ x -> '"':x ++ "\"")
+		      _      -> (break isSpace rs', id)
+
+		bs' =
+		  case bs of
+		    []     -> []
+		    (_:xs) -> xs
+
+		tok     = T_include (wrapper as)
+	    setTok tok
+	    setStream bs'
+	    cont tok
+
+       Just T_ignore_start -> do
+           ls <- getStream
+           case (dropUntil "__ignore_end__" ls) of
+	      [] -> cont T_eof
+	      xs -> setStream xs >> lexIDL cont
+       Just tok -> setTok tok >> setStream rs >> cont tok
+       Nothing  -> setTok (T_id is) >> setStream rs >> cont (T_id is)
+
+is_id_char :: Char -> Bool
+is_id_char ch = isAlpha ch || isDigit ch || ch == '_' || ch == '$' || ch == '.'
+
+dropUntil :: String -> String -> String
+dropUntil _pref [] = []
+dropUntil pref  ls@(_:xs)
+ | pref `isPrefixOf` ls = drop (length pref) ls
+ | otherwise = dropUntil pref xs
+
+lex_string :: (IDLToken -> LexM a) -> LexM a
+lex_string cont = do
+ cs <- getStream
+ --assert (head cs /= '\"')
+ case loop cs of 
+  (str,cs1) -> do
+     setStream cs1
+     cont (T_string_lit (deEscapeString str))
+  where
+   not_quote_nor_esc ch = ch /= '\"' && ch /= '\\'
+
+   loop cs =
+    case span not_quote_nor_esc cs of
+     (ls,'\\':rs) -> 
+      case rs of
+       ('"':rs1) -> -- escaped quote, just continue.
+	  let
+	   (as,bs) = loop rs1
+	  in
+	  (ls++'\\':'\"':as, bs)
+       ('\\':rs1) -> -- want \\" to be interpreted as \\ ", not \ \"
+	  let
+	   (as,bs) = loop rs1
+	  in
+	  (ls++'\\':'\\':as, bs)
+       _ -> -- just continue.
+	  let
+	   (as,bs) = loop rs
+	  in
+	  (ls++'\\':as, bs)
+     (ls,'\"':rs) -> (ls,rs)
+     x -> x
+   	  
+lex_char :: (IDLToken -> LexM a) -> LexM a
+lex_char cont = do
+ cs <- getStream
+ loop cs
+  where
+   not_quote_nor_esc ch = ch /= '\'' && ch /= '\\'
+   loop cs = 
+    case span not_quote_nor_esc cs of
+     ([],'\\':rs) ->
+        case rs of
+          '\\':'\'':rs1 -> setStream rs1  >>          cont (T_literal (CharLit '\\'))
+          x:'\'':rs1 -> setStream rs1     >>          cont (T_literal (CharLit (read ['\\',x])))
+          _          -> getSrcLoc         >>= \ sl -> cont (T_unknown (sl,cs))
+     (ls,'\'':rs) -> setStream rs         >>          cont (T_literal (CharLit (read ls)))
+     (ls,rs) -> setStream rs >> getSrcLoc >>= \ sl -> cont (T_unknown (sl,ls))
+\end{code}
+
+
+
+ src/LexM.lhs view
@@ -0,0 +1,281 @@+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+
+The @LexM@ hides the information maintained by the IDL lexer
+(and parser.)
+
+
+\begin{code}
+module LexM 
+
+       (
+         LexM
+	
+       , runLexM         -- :: [FilePath] -> String -> LexM a -> IO (a, SymbolTable IDLToken)
+       , invokeLexM      -- :: String -> String -> LexM a -> LexM a
+       , ioToLexM        -- :: IO a   -> LexM a
+       , incLineNo       -- :: LexM a -> LexM a
+       , setSrcLoc       -- :: SrcLoc -> LexM a -> LexM a
+       , getSrcLoc       -- :: LexM SrcLoc
+       , getOrigSrcLoc   -- :: LexM SrcLoc
+       , getPath         -- :: LexM [FilePath]
+       , isEOF           -- :: LexM Bool
+       , getNextChar     -- :: LexM Char
+       , putBackChar     -- :: Char -> LexM ()
+       , getStream       -- :: LexM String
+       , setStream       -- :: String -> LexM ()
+       , lookupSymbol    -- :: String -> LexM (Maybe IDLToken)
+       , lookupType      -- :: String -> LexM (Maybe IDLToken)
+       , addBuiltinType  -- :: String -> LexM ()
+       , addTypedef      -- :: String -> LexM ()
+       , setTok
+       , getTok
+       
+       , inSystemContext
+       , getSystemContextFlag
+
+       , cacheFilePath
+       , alreadySeenFile
+       , importFile
+       
+       , handleImportLib
+       , slurpImports
+
+       , thenLexM
+       , returnLexM
+       ) where
+
+import Data.IORef
+import qualified SymbolTable
+import SrcLoc
+import IDLToken
+import IDLSyn
+import PreProc
+import Utils   ( tryOpen, dropSuffix )
+import Opts    ( optVerbose, optConvertImportLibs )
+import IO      ( hPutStrLn, stderr )
+import Monad   ( when )
+import Char    ( toLower )
+
+-- components threaded by the monad (apart from
+-- the IO token.)
+data LexState
+ = LexState {
+      sym_table  :: SymbolTable.SymbolTable IDLToken,
+      cur_tok    :: Maybe IDLToken, {- current token (for error msgs.) -}
+      inp_stream :: String     {- input stream -}
+  }
+
+data LexEnv = 
+  LexEnv {
+    env_src_loc     :: SrcLoc,
+    env_origsrc_loc :: SrcLoc,
+    env_in_system   :: Bool,
+    env_file_path   :: [FilePath],      -- search path for imported .idl files.
+    env_file_cache  :: IORef [FilePath] -- already imported .idl files.
+  }
+
+newtype LexM a = LexM (  LexEnv -> LexState -> IO (a, LexState))
+
+runLexM :: [String]
+        -> String
+        -> String 
+        -> LexM a 
+	-> IO a
+runLexM path fname str (LexM m) = do
+  var <- newIORef []
+  let sl = (mkSrcLoc fname 1)
+  (v, _) <- m (LexEnv sl sl False path var) 
+              (LexState (SymbolTable.mkSymbolTable idlKeywords) Nothing str)
+  return v
+
+-- nested invocations of LexM actions share
+-- the keyword part of the symbol table + the cache
+-- of already seen files.
+invokeLexM :: String -> String -> LexM a -> LexM a
+invokeLexM fname ls (LexM m) =
+ LexM (\ (LexEnv _ _ flg path var) (LexState symt tok cs) -> do
+    let -- symt1 = SymbolTable.newContext symt
+        sl    = (mkSrcLoc fname 1)
+    (v, LexState symt2 _ _) 
+      <- m (LexEnv sl sl flg path var)
+	   (LexState symt tok ls)
+    return (v, LexState symt2{-(SymbolTable.combineSyms symt symt2)-} tok cs))
+
+ioToLexM :: IO a -> LexM a
+ioToLexM act =
+ LexM (\ _ st -> do
+         v <- act
+	 return (v, st))
+
+cacheFilePath :: FilePath -> LexM ()
+cacheFilePath f =
+ LexM (\ (LexEnv{env_file_cache=fp}) st -> do
+     ls <- readIORef fp
+     writeIORef fp (f:ls)
+     return ((), st))
+
+alreadySeenFile :: FilePath -> LexM Bool
+alreadySeenFile f =
+ LexM (\ (LexEnv{env_file_cache=fp}) st -> do
+     ls <- readIORef fp
+     return (f `elem` ls, st))
+
+incLineNo :: LexM a -> LexM a
+incLineNo (LexM m) = 
+ LexM (\ env@(LexEnv{env_src_loc=l}) st -> m (env{env_src_loc=incSrcLineNo l}) st)
+
+setSrcLoc :: SrcLoc -> LexM a -> LexM a
+setSrcLoc new_loc (LexM m) = LexM (\ env st -> m (env{env_src_loc=new_loc}) st)
+
+inSystemContext :: Bool -> LexM a -> LexM a
+inSystemContext flg (LexM m) = LexM (\ env st -> m (env{env_in_system=flg}) st)
+
+getSystemContextFlag :: LexM Bool
+getSystemContextFlag = LexM (\ env st -> return (env_in_system env, st))
+
+getSrcLoc :: LexM SrcLoc
+getSrcLoc = LexM (\ env st -> return (env_src_loc env, st))
+
+getOrigSrcLoc :: LexM SrcLoc
+getOrigSrcLoc = LexM (\ env st -> return (env_origsrc_loc env, st))
+
+getPath :: LexM [FilePath]
+getPath = LexM (\ env st -> return (env_file_path env, st))
+
+isEOF :: LexM Bool
+isEOF = LexM (\ _ st -> return (null (inp_stream st), st))
+
+getNextChar :: LexM Char
+getNextChar = 
+  LexM (\ _ st ->
+     case inp_stream st of
+       (c:cs) -> return (c, st{inp_stream=cs})
+       _      -> return (error "getNextChar: stream is empty", st))
+
+putBackChar :: Char -> LexM ()
+putBackChar c = LexM ( \ _ st -> return ((), st{inp_stream=c:inp_stream st}))
+
+getStream :: LexM String
+getStream = LexM (\ _ st -> return (inp_stream st, st))
+
+setStream :: String -> LexM ()
+setStream cs = LexM (\ _ st -> return ((), st{inp_stream=cs}))
+
+lookupSymbol :: String -> LexM (Maybe IDLToken)
+lookupSymbol str = 
+  LexM (\ _ st -> return (SymbolTable.lookupSymbol (sym_table st) str, st))
+
+lookupType :: String -> LexM (Maybe IDLToken)
+lookupType str = 
+  LexM (\ _ st -> return (SymbolTable.lookupType (sym_table st) str, st))
+
+-- back door entry for adding new types after we've installed
+-- the default set.
+addBuiltinType :: String -> LexM ()
+addBuiltinType str =
+ LexM (\ _ st ->
+     return ( ()
+            , st{sym_table=SymbolTable.addKeyword (sym_table st) str (T_type str)}))
+
+addTypedef :: String -> LexM ()
+addTypedef str =
+ LexM (\ _ st ->
+       return (()
+              , st{sym_table=SymbolTable.addType (sym_table st) str (T_type str)}))
+
+setTok :: IDLToken -> LexM ()
+setTok t = LexM (\ _ st -> return ((),st{cur_tok=Just t}))
+
+getTok :: LexM (Maybe IDLToken)
+getTok = LexM (\ _ st -> return (cur_tok st, st))
+
+-----
+
+thenLexM :: LexM a -> (a -> LexM b) -> LexM b
+thenLexM (LexM m) n =
+ LexM ( \ env st -> do
+          (a, st1) <- m env st
+	  let (LexM act) = n a
+	  act env st1 )
+
+returnLexM :: a -> LexM a
+returnLexM v = LexM (\ _ st -> return (v, st) )
+
+{- UNUSED
+mapLexM :: (a -> b) -> LexM a -> LexM b
+mapLexM f (LexM m) =
+ LexM (\ env st -> do
+   (x,st1) <- m env st
+   return (f x, st1))
+-}
+
+instance Monad LexM where
+  (>>=)  = thenLexM
+  return = returnLexM
+
+\end{code}
+
+\begin{code}
+importFile :: String -> LexM (Maybe String)
+importFile fname = do
+  path  <- getPath 
+  res   <- ioToLexM (tryOpen optVerbose path exts fname)
+  case res of
+    Nothing   -> do
+        l   <- getSrcLoc
+        ioToLexM (ioError
+		     (userError  (show l ++": Unable to import "++ fname)))
+        
+    Just fn   -> do
+        flg <- alreadySeenFile fn
+        if flg
+	 then do
+           ioToLexM (when optVerbose (hPutStrLn stderr (show fn ++ " already loaded.")))
+	   return Nothing -- already slurped this one.
+	 else do
+           cacheFilePath fn
+	   res1 <- ioToLexM (preProcessFile fn)
+	   ls   <- ioToLexM (readFile res1)
+	   return (Just ls)
+ where
+  exts = [""]
+
+\end{code}
+
+\begin{code}
+handleImportLib :: LexM [Defn] -> String -> LexM Defn
+handleImportLib parse str
+ | not optConvertImportLibs = do
+{- BEGIN_NOT_TLB_SUPPORT
+     warningMsg ("ignoring importlib("++show str ++"): Type library imports not supported")
+   END_NOT_TLB_SUPPORT -}
+     return (ImportLib str) 
+ | otherwise  = slurpImports parse [str']
+  where
+    str' = dropSuffix (map toLower str) ++ ".idl"
+\end{code}
+
+\begin{code}
+
+slurpImports :: LexM [Defn] -> [String] -> LexM Defn
+slurpImports parse ls = do
+  defss <- mapM (slurpImport parse) ls
+  return (Import (zip ls defss))
+
+--
+-- Importing an IDL file means bringing the types and interfaces
+-- into scope, no code is generated for the interfaces.
+--
+slurpImport :: LexM [a] -> String -> LexM [a]
+slurpImport parse fname = do
+  flg           <- alreadySeenFile fname
+  if flg
+   then return []
+   else do
+     mb_ls  <- importFile fname
+     case mb_ls of
+       Nothing -> return []
+       Just ls -> invokeLexM fname ls (parse)
+\end{code}
+ src/LibUtils.lhs view
@@ -0,0 +1,706 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 9th 2003  15:53  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+The generated code makes use of a number of library functions. This
+module abstracts away from their names and locations.
+
+\begin{code}
+module LibUtils
+        (
+	  hdirectLib
+	, bitsLib
+	, comLib
+	, comServLib
+	, prelude
+	, maybe_module
+	, autoLib
+	, ioExts
+	, intLib
+	, wordLib
+--	, addrLib
+	, foreignLib
+	, arrayLib
+	, jniLib
+	, wStringLib
+	, safeArrayLib
+	, ptrLib
+	, foreignPtrLib
+	
+	, iDispatch
+	, iUnknown
+	, iUnknownFO
+	, iID
+	, cLSID
+	, gUID
+	, lIBID
+	, mkIID
+	, mkCLSID
+	, mkLIBID
+	, primIP
+	, currency
+	, variantClass
+	, variantType
+	, groundInterface
+
+	, vARIANT
+	, sAFEARRAY
+
+	, derefPtr
+	, indexPtr
+	, interfacePtrToAddr
+	, intToAddr
+	, mkWString
+	, lengthWString
+	
+	, castPtrName
+	, castFPtrName
+	, withForeignPtrName
+
+	, checkHR
+	, check2HR
+	, invokeAndCheck
+	, returnHR
+	, invokeIt
+	, primInvokeIt
+	
+	, getIfaceState
+	, createComVTable
+	, createDispVTable
+	, comVTableTy
+	, createComInst
+	, mkComInterface
+	, mkDispInterface
+	, mkDualInterface
+	, comInterfaceTy
+	
+	, componentInfo
+	, mkComponentInfo
+	, hasTypeLib
+	
+	, mkForeignObj
+
+	, trivialFree
+	, allocOutPointer
+	, allocBytes
+	, allocWords
+
+	, list
+	, blist
+	, bstring
+	, ref
+	, unique
+--	, ptr
+	, fptr
+	, iptr
+	, wstring
+	, wstring2
+
+	, enum32
+	, enum16
+
+	, stringName
+	, bool
+	, integer
+	, bstr
+	, safearray
+	, ptrName
+	, funPtrName
+	, foreignPtrName
+	
+	, free
+	, freeRef
+	, doThenFree
+	, nullPtr
+	, nullFO
+	, nullFinaliser
+	, nullIPointer
+	, prelError
+	, raiseIOException
+	, prelUserError
+	, prelReturn
+	, bindName
+	, bind_Name
+	
+        , xorName
+        , orName
+        , andName
+        , shiftLName
+        , shiftRName
+	, bitsClass
+	, complementName
+	, shiftName
+	, rotateName
+	, bitSizeName
+	, isSignedName
+
+        , addName
+        , subName
+        , divName
+        , modName
+        , mulName
+        , logAndName
+        , logOrName
+        , gtName
+        , geName
+        , eqName
+        , leName
+        , ltName
+        , neName
+        , negateName
+        , notName
+
+	, marshStruct
+	, unmarshStruct
+	, marshUnion
+	, unmarshUnion
+	
+	, dollarName
+	, inArgName
+	, inIUnknownArgName
+	, outArgName
+	, inoutArgName
+	, retValName
+	, applyName
+	, mkDispMethod
+	
+	, enumClass
+	, eqClass
+	, showClass
+	, numClass
+
+	, fromEnumName
+	, toEnumName
+	
+	, enumToInt
+	, enumToFlag
+	, unboxInt
+	, flagToIntTag
+	, tagToEnum
+	, toIntFlag
+	, pow2Series
+	, orListName
+	, orFlagsName
+	, orFlagName
+	, flagsClass
+	
+	, inVariantName
+	, resVariantName
+	, defaultVariantName
+	, vtEltTypeName
+
+	, fromMaybeName
+	, maybeName
+	, justName
+	, nothingName
+	, mapName
+	, mapListName
+	, concatName
+	, concatMapName
+	, intersectName
+	, mapMaybeName
+	, sumName
+	, fromIntegralName
+	, lengthName
+	
+	, true
+	, false
+	
+	, uPerformIO
+
+	, marshallPrefix
+	, marshallRefPrefix
+	, unmarshallPrefix
+	, unmarshallRefPrefix
+	, sizeofPrefix
+	, sizeOfName
+	, outPrefix
+	, allocPrefix
+	, freePrefix
+	, copyPrefix
+	
+	, marshallMaybe
+	, writeMaybe
+	, readMaybe
+
+        , mkPrimitiveName
+	, mkWrapperName
+        , mkPrimExportName
+	, mkVtblOffsetName
+	, mkCLSIDName
+	, mkLIBIDName
+	
+	, defaultCConv
+	
+	, invokeMethod
+	, invokeStaticMethod
+	, invokeInterfaceMethod
+	, getField
+	, getStaticField
+	, setField
+	, setStaticField
+	, inArg
+	, jvalueClass
+	, jObject
+	, jArray
+	, jniEnv
+	, fPointer
+
+	, newObj
+	, className
+	, makeClassName
+	, mkClassName
+	, newFPointer
+	
+	, orbLib
+	, cObject
+	
+       ) where
+
+import BasicTypes
+import Opts ( optHaskellToC, optH1_4, 
+	      optCorba
+	    )
+
+\end{code}
+
+Where it's at - the different modules we may end up
+generating imports from:
+
+\begin{code}
+hdirectLib, bitsLib, comLib, comServLib, listLib, ptrLib, foreignPtrLib :: Maybe String
+hdirectLib = Just "HDirect"
+bitsLib = Just "Bits"
+comLib  = Just "Com"
+comServLib  = Just "ComServ"
+listLib = Just "List"
+ptrLib  = Just "Foreign.Ptr"
+foreignPtrLib = Just "Foreign.ForeignPtr"
+
+comDll, prelude, prelGHC, maybe_module, autoLib, ioExts :: Maybe String
+comDll  = Just "ComDll"
+prelude = Just "Prelude"
+prelGHC = Just "PrelGHC"
+maybe_module = Just "Maybe"
+autoLib = Just "Automation"
+ioExts  = Just "System.IO"
+
+intLib, wordLib, foreignLib, arrayLib :: Maybe String
+intLib  = Just "Int"
+wordLib = Just "Word"
+--addrLib = Just "Addr"
+foreignLib = Just "Foreign"
+arrayLib   = Just "Array"
+
+stdDispatchLib, wStringLib, jniLib, orbLib, safeArrayLib :: Maybe String
+stdDispatchLib = Just "StdDispatch"
+wStringLib = Just "WideString"
+safeArrayLib = Just "SafeArray"
+
+jniLib = Just "JNI"
+orbLib = Just "Corba"
+
+\end{code}
+
+Some standard COM types/functions :
+
+\begin{code}
+iDispatch, iUnknown, iUnknownFO, primIP, iID, cLSID, gUID, lIBID, mkIID, mkCLSID, mkLIBID :: QualName
+iDispatch  = mkQualName autoLib "IDispatch"
+iUnknown   = mkQualName comLib "IUnknown"
+iUnknownFO = mkQualName comLib "IUnknownFO"
+primIP     = mkQualName comLib "PrimIP"
+iID        = mkQualName comLib "IID"
+cLSID      = mkQualName comLib "CLSID"
+gUID       = mkQualName comLib "GUID"
+lIBID      = mkQualName comLib "LIBID"
+mkIID      = mkQualName comLib "mkIID"
+mkCLSID    = mkQualName comLib "mkCLSID"
+mkLIBID    = mkQualName comLib "mkLIBID"
+
+mkForeignObj, nullIPointer, groundInterface :: QualName
+
+-- since ghc-4.08.1's Foreign.makeForeignObj doesn't quite work,
+-- we rely on the FO creator in the HDirect support libs instead.
+--mkForeignObj = mkQualName foreignLib "makeForeignObj"
+mkForeignObj = mkQualName (Just "Pointer") "makeFO"
+
+nullIPointer = mkQualName comLib "interfaceNULL"
+
+groundInterface = mkQualName Nothing "()"
+
+currency, vARIANT, sAFEARRAY :: QualName
+currency     = mkQualName autoLib "Currency"
+vARIANT      = mkQualName autoLib "VARIANT"
+sAFEARRAY    = mkQualName safeArrayLib "SAFEARRAY"
+
+dollarName :: QualName
+dollarName   = mkQualName prelude "$"
+
+derefPtr, interfacePtrToAddr, intToAddr, indexPtr :: QualName
+derefPtr      = mkQualName hdirectLib "derefPtr"
+interfacePtrToAddr = mkQualName comLib "interfacePtrToAddr"
+intToAddr      = mkQualName hdirectLib "intToAddr"
+indexPtr       = mkQualName hdirectLib "indexPtr"
+
+castPtrName, castFPtrName, withForeignPtrName :: QualName
+castPtrName    = mkQualName ptrLib     "castPtr"
+castFPtrName   = mkQualName foreignPtrLib "castForeignPtr"
+withForeignPtrName = mkQualName foreignPtrLib "withForeignPtr"
+
+checkHR, check2HR, invokeAndCheck, returnHR, invokeIt, primInvokeIt :: QualName
+checkHR	       = mkQualName comLib "checkHR"
+check2HR       = mkQualName comLib "check2HR"
+invokeAndCheck = mkQualName comLib "invokeAndCheck"
+returnHR       = mkQualName comLib "returnHR"
+invokeIt       = mkQualName comLib "invokeIt"
+primInvokeIt   = mkQualName hdirectLib "primInvokeIt"
+
+variantClass, variantType, inVariantName, resVariantName, defaultVariantName, vtEltTypeName :: QualName
+variantClass   = mkQualName autoLib "Variant"
+variantType    = mkQualName autoLib "VARIANT"
+inVariantName  = mkQualName autoLib "inVariant"
+resVariantName = mkQualName autoLib "resVariant"
+defaultVariantName = mkQualName autoLib "defaultVariant"
+vtEltTypeName  = mkQualName autoLib "vtEltType"
+
+getIfaceState, createComVTable, comVTableTy, createComInst :: QualName
+getIfaceState    = mkQualName comServLib "getObjState"
+createComVTable  = mkQualName comServLib "createComVTable"
+comVTableTy      = mkQualName comServLib "ComVTable"
+createComInst    = mkQualName comServLib "createComInstance"
+
+mkComInterface, mkDispInterface, mkDualInterface, comInterfaceTy :: QualName
+mkComInterface   = mkQualName comServLib "mkIface"
+mkDispInterface  = mkQualName comServLib "mkDispIface"
+mkDualInterface  = mkQualName comServLib "mkDualIface"
+comInterfaceTy   = mkQualName comServLib "ComInterface"
+
+componentInfo, mkComponentInfo, hasTypeLib :: QualName
+componentInfo    = mkQualName comDll "ComponentInfo"
+mkComponentInfo  = mkQualName comDll "mkComponentInfo"
+hasTypeLib       = mkQualName comDll "hasTypeLib"
+
+inArgName, inIUnknownArgName, outArgName, inoutArgName, retValName, applyName :: QualName
+inArgName         = mkQualName stdDispatchLib "inArg"
+inIUnknownArgName = mkQualName stdDispatchLib "inIUnknownArg"
+outArgName        = mkQualName stdDispatchLib "outArg"
+inoutArgName      = mkQualName stdDispatchLib "inoutArg"
+retValName        = mkQualName stdDispatchLib "retVal"
+applyName         = mkQualName stdDispatchLib "apply_"
+
+createDispVTable, mkDispMethod :: QualName
+createDispVTable = mkQualName stdDispatchLib "createStdDispatchVTBL2"
+mkDispMethod     = mkQualName stdDispatchLib "mkDispMethod"
+
+trivialFree, free, freeRef, doThenFree :: QualName
+trivialFree   = mkQualName hdirectLib "trivialFree"
+free          = mkQualName hdirectLib "free"
+freeRef	      = mkQualName hdirectLib "freeref"
+doThenFree    = mkQualName hdirectLib "doThenFree"
+
+nullPtr, nullFO, nullFinaliser, prelError, prelFail, prelIOError :: QualName
+nullPtr       = mkQualName ptrLib     "nullPtr"
+nullFO        = mkQualName hdirectLib "nullFO"
+nullFinaliser = mkQualName hdirectLib "nullFinaliser"
+prelError     = mkQualName prelude    "error"
+prelFail      = mkQualName prelude    "fail"
+prelIOError   = mkQualName prelude    "ioError"
+
+prelUserError, prelReturn, bindName, bind_Name :: QualName
+prelUserError = mkQualName prelude    "userError"
+prelReturn    = mkQualName prelude    "return"
+bindName      = mkQualName prelude    ">>="
+bind_Name     = mkQualName prelude    ">>"
+
+xorName, orName, andName, shiftLName, shiftRName :: QualName
+xorName       = mkQualName bitsLib    "xor"
+orName        = mkQualName bitsLib    ".|."
+andName       = mkQualName bitsLib    ".&."
+shiftLName    = mkQualName bitsLib    "shiftL"
+shiftRName    = mkQualName bitsLib    "shiftR"
+
+complementName, shiftName, rotateName, bitSizeName, isSignedName :: QualName
+complementName = mkQualName bitsLib    "complement"
+shiftName      = mkQualName bitsLib    "shift"
+rotateName     = mkQualName bitsLib    "rotate"
+bitSizeName    = mkQualName bitsLib    "bitSize"
+isSignedName   = mkQualName bitsLib    "isSigned"
+
+bitsClass :: QualName
+bitsClass     = mkQualName bitsLib    "Bits"
+
+addName, subName, divName, modName, mulName :: QualName
+addName       = mkQualName prelude    "+"
+subName       = mkQualName prelude    "-"
+divName       = mkQualName prelude    "div"
+modName       = mkQualName prelude    "mod"
+mulName       = mkQualName prelude    "*"
+
+logAndName, logOrName :: QualName
+logAndName    = mkQualName prelude    "&&"
+logOrName     = mkQualName prelude    "||"
+gtName, geName, eqName, leName, ltName, neName :: QualName
+gtName        = mkQualName prelude    ">"
+geName        = mkQualName prelude    ">="
+eqName        = mkQualName prelude    "=="
+leName        = mkQualName prelude    "<="
+ltName        = mkQualName prelude    "<"
+neName        = mkQualName prelude    "/="
+
+negateName, notName :: QualName
+negateName    = mkQualName prelude    "negate"
+notName       = mkQualName prelude    "not"
+
+marshStruct, unmarshStruct, marshUnion, unmarshUnion :: QualName
+marshStruct   = mkQualName hdirectLib "marshallStruct"
+unmarshStruct = mkQualName hdirectLib "unmarshallStruct"
+marshUnion    = mkQualName hdirectLib "marshallUnion"
+unmarshUnion  = mkQualName hdirectLib "unmarshallUnion"
+
+marshallMaybe, writeMaybe, readMaybe :: QualName
+marshallMaybe = mkQualName hdirectLib "marshallMaybe"
+writeMaybe    = mkQualName hdirectLib "writeMaybe"
+readMaybe     = mkQualName hdirectLib "readMaybe"
+
+eqClass, numClass, showClass, enumClass, fromEnumName, toEnumName :: QualName
+eqClass       = mkQualName prelude "Eq"
+showClass     = mkQualName prelude "Show"
+numClass      = mkQualName prelude "Num"
+enumClass     = mkQualName prelude "Enum"
+fromEnumName  = mkQualName prelude "fromEnum"
+toEnumName    = mkQualName prelude "toEnum"
+
+enumToInt, enumToFlag, flagToIntTag, pow2Series :: QualName
+enumToInt     = mkQualName hdirectLib "enumToInt"
+enumToFlag    = mkQualName hdirectLib "enumToFlag"
+flagToIntTag  = mkQualName hdirectLib "flagToIntTag"
+pow2Series    = mkQualName hdirectLib "pow2Series"
+
+orListName :: QualName
+orListName    = mkQualName hdirectLib "orList"
+
+orFlagsName :: QualName
+orFlagsName    = mkQualName hdirectLib "orFlags"
+
+flagsClass :: QualName
+flagsClass = mkQualName hdirectLib "Flags"
+
+orFlagName :: QualName
+orFlagName = mkQualName hdirectLib ".+."
+
+unboxInt, tagToEnum, toIntFlag :: QualName
+unboxInt      = mkQualName hdirectLib "unboxInt"
+tagToEnum     = mkQualName prelGHC    "tagToEnum#"
+toIntFlag     = mkQualName hdirectLib "toIntFlag"
+
+fromMaybeName, maybeName :: QualName
+fromMaybeName = mkQualName maybe_module "fromMaybe"
+maybeName     = mkQualName prelude "Maybe"
+justName, nothingName :: QualName
+justName      = mkQualName prelude "Just"
+nothingName   = mkQualName prelude "Nothing"
+
+lengthName :: QualName
+lengthName = mkQualName prelude "length"
+
+mapName :: QualName
+mapName
+ | optH1_4    = mkQualName prelude "map"
+ | otherwise  = mkQualName prelude "fmap"
+
+mapListName :: QualName
+mapListName   = mkQualName prelude "map"
+
+concatName :: QualName
+concatName   = mkQualName prelude "concat"
+
+concatMapName :: QualName
+concatMapName   = mkQualName listLib "concatMap"
+
+intersectName :: QualName
+intersectName   = mkQualName listLib "intersect"
+
+mapMaybeName :: QualName
+mapMaybeName   = mkQualName maybe_module "mapMaybe"
+
+sumName :: QualName
+sumName   = mkQualName prelude "sum"
+
+fromIntegralName :: QualName
+fromIntegralName = mkQualName prelude "fromIntegral"
+
+true, false :: QualName
+true	      = mkQualName prelude "True"
+false	      = mkQualName prelude "False"
+
+uPerformIO :: QualName
+uPerformIO    = mkQualName ioExts  "unsafePerformIO"
+
+mkWString :: QualName
+mkWString     = mkQualName wStringLib "mkWideString"
+
+lengthWString :: QualName
+lengthWString     = mkQualName wStringLib "lengthWideString"
+
+allocOutPointer, allocBytes, allocWords :: QualName
+allocOutPointer = mkQualName hdirectLib "allocOutPtr"
+allocBytes	= mkQualName hdirectLib "allocBytes"
+allocWords	= mkQualName hdirectLib "allocWords"
+\end{code}
+
+\begin{code}
+list, blist, bstring, fptr, iptr :: String
+list    = "list"
+blist   = "blist"
+bstring = "BString"
+--ptr     = "ptr"
+fptr    = "fptr"
+iptr    = "iptr"
+
+ref, unique :: String
+ref     = "ref"
+unique  = "unique"
+
+stringName , wstring, wstring2 :: String
+stringName = "String"
+wstring    = "WideString"
+wstring2   = "WideString2"
+
+ptrName, funPtrName, foreignPtrName :: String
+ptrName  = "Ptr"
+funPtrName = "FunPtr"
+foreignPtrName = "ForeignPtr"
+
+bool, integer, bstr, safearray :: String
+bool    = "Bool"
+integer = "Integer"
+bstr    = "BSTR"
+safearray = "SafeArray"
+
+enum32, enum16 :: String
+enum32  = "Enum32"
+enum16  = "Enum16"
+\end{code}
+
+
+The Haskell names for the different functions that we generate
+during the translation from IDL to Haskell are formed by adding
+a prefix to the (Haskell) type of the value we're marshalling
+to/from:
+
+\begin{code}
+outPrefix, unmarshallPrefix, marshallPrefix :: String
+marshallPrefix      = "marshall"
+outPrefix           = "o_"
+unmarshallPrefix    = "unmarshall"
+
+marshallRefPrefix, unmarshallRefPrefix, allocPrefix, sizeofPrefix :: String
+marshallRefPrefix   = "write"
+unmarshallRefPrefix = "read"
+allocPrefix         = "alloc"
+sizeofPrefix        = "sizeof"
+
+freePrefix, copyPrefix :: String
+freePrefix          = "free"
+copyPrefix          = "copy"
+
+-- given the name of a method/function, produce the
+-- name of the primitive Haskell function that represent it.
+mkPrimitiveName :: String -> String
+mkPrimitiveName nm = "prim_"++nm
+
+-- wrappers are Haskell functions that convert between
+-- the expected signature of an external function type or method
+-- and the Haskell implementation - i.e., arguments are marshalled
+-- prior to calling the Haskell function, followed by unmarshalling
+-- it's result.
+mkWrapperName :: String -> String
+mkWrapperName nm = "wrap_"++nm
+
+mkPrimExportName :: String -> String
+mkPrimExportName nm = "export_" ++ nm
+
+mkVtblOffsetName :: String -> String -> String
+mkVtblOffsetName iface meth = "off_" ++ iface ++ '_':meth
+
+
+mkCLSIDName :: String -> String
+mkCLSIDName cls_nm = "clsid" ++ cls_nm
+
+mkLIBIDName :: String -> String
+mkLIBIDName cls_nm = "libid" ++ cls_nm
+
+mkClassName :: String -> String
+mkClassName nm = nm ++ "ClassName"
+\end{code}
+
+\begin{code}
+invokeMethod :: QualName
+invokeMethod          = mkQualName jniLib "callMethodPrim"
+
+invokeStaticMethod :: QualName
+invokeStaticMethod    = mkQualName jniLib "invokeStaticMethod"
+
+invokeInterfaceMethod :: QualName
+invokeInterfaceMethod = mkQualName jniLib "callMethodPrim"
+
+getField :: QualName
+getField              = mkQualName jniLib "getFieldPrim"
+
+getStaticField :: QualName
+getStaticField        = mkQualName jniLib "get_StaticField"
+
+setField :: QualName
+setField              = mkQualName jniLib "setFieldPrim"
+
+setStaticField :: QualName
+setStaticField        = mkQualName jniLib "set_StaticField"
+
+inArg, jvalueClass, jObject, jArray, jniEnv :: QualName
+inArg         = mkQualName jniLib "inVal"
+jvalueClass   = mkQualName jniLib "JValue"
+jObject       = setOrigQName "java.lang.Object" (mkQualName jniLib "JObject")
+jArray        = mkQualName jniLib "JArray"
+jniEnv        = mkQualName jniLib "JNIEnv"
+
+fPointer, newObj, className, makeClassName, newFPointer :: QualName
+fPointer      = mkQualName jniLib "FunctionPtr"
+newObj        = mkQualName jniLib "new"
+className     = mkQualName jniLib "ClassName"
+makeClassName = mkQualName jniLib "mkClassName"
+newFPointer   = mkQualName jniLib "new_FunctionPtr"
+\end{code}
+
+\begin{code}
+cObject :: QualName
+cObject  = mkQualName orbLib "Object"
+
+\end{code}
+
+The method calling convention used if none specified.
+
+\begin{code}
+defaultCConv :: CallConv
+defaultCConv 
+ | optHaskellToC || optCorba = Cdecl
+ | otherwise     = Stdcall
+\end{code}
+
+\begin{code}
+raiseIOException :: QualName
+raiseIOException 
+  | optH1_4   = prelFail
+  | otherwise = prelIOError
+\end{code}
+
+FFI names
+
+\begin{code}
+sizeOfName :: String
+sizeOfName = "sizeOf"
+
+\end{code}
+ src/Literal.lhs view
@@ -0,0 +1,118 @@+%
+% (c) The Foo Project, University of Glasgow 1998
+% @(#) $Docid: Oct. 9th 1999  15:28  Sigbjorn Finne $
+% @(#) $Contactid: v-sfinne@microsoft.com $
+%
+
+\begin{code}
+module Literal 
+	(
+	  Literal(..)
+
+	, IntegerLit(..)
+	, iLit			-- :: Integral a => a -> Literal
+	, iLitToIntegral	-- :: Integral a => IntegerLit -> a
+	, iLitToInteger		-- :: IntegerLit -> Integer
+	
+	, ppLit
+	, ppILit
+	, litToString
+	
+	) where
+
+import PP
+import Utils
+import List ( intersperse )
+import Opts ( optNoQualNames )
+\end{code}
+
+\begin{code}
+data Literal
+ = IntegerLit  IntegerLit
+ | StringLit   String
+ | TypeConst   String    -- type constant.
+ | WStringLit  String
+ | CharLit     Char
+ | WCharLit    Char
+ | FixedPtLit  Rational
+ | FloatingLit (String, Double)
+ | BooleanLit  Bool
+ | NullLit
+ | GuidLit     [String]
+ | LitLit      String   -- lit-lits live on.
+   deriving ( 
+              Show -- for Lex debugging only
+            , Eq
+	    ) 
+
+data IntegerLit = ILit Int{-base-} Integer
+                  deriving (
+		             Show -- for Lex debugging only
+			   , Eq
+			   ) 
+iLit :: Integral a => a -> Literal
+iLit x = IntegerLit (ILit 10 (toInteger x))
+
+iLitToIntegral :: Integral a => IntegerLit -> a
+iLitToIntegral (ILit _ x) = fromInteger x
+
+iLitToInteger :: IntegerLit -> Integer
+iLitToInteger (ILit _ x) = x
+
+litToString :: Literal -> String
+litToString l = 
+  case l of
+    IntegerLit  (ILit _ v) -> show v
+    StringLit   s -> s
+    TypeConst   s -> s
+    WStringLit  s -> s
+    CharLit     c -> [c]
+    WCharLit    c -> [c]
+    FixedPtLit  r -> show r
+    FloatingLit (s,_) -> s
+    BooleanLit  b     -> show b
+    GuidLit     [g]   -> g
+    NullLit           -> "0"
+    GuidLit     gs    -> '{':concat (intersperse "-" gs) ++ "}"
+    LitLit      s     -> s
+
+\end{code}
+
+%*
+%
+\subsection{Pretty printing literals}
+%
+%*
+
+\begin{code}
+ppLit :: Literal -> PPDoc a
+ppLit (IntegerLit ilit)   = ppILit ilit
+ppLit (StringLit s)       = text (show s)
+ppLit (WStringLit ws)     = text (show ws)
+ppLit (TypeConst s)       = text s
+ppLit (CharLit c)         = text (show c)
+ppLit (WCharLit c)        = text (show c)
+ppLit (FixedPtLit r)      = rational r
+ppLit (FloatingLit (d,x)) 
+  | x < 0.0   = parens (text d)
+  | otherwise = text d
+ppLit (BooleanLit b)
+  | optNoQualNames = text (if b then "True" else "False")
+  | otherwise      = text (if b then "Prelude.True" else "Prelude.False")
+
+ppLit (GuidLit ls)        = hcat (punctuate (char '-') (map text ls))
+ppLit (LitLit ls)         = text ls
+ppLit NullLit             = text "NULL"
+
+ppILit :: IntegerLit -> PPDoc a
+ppILit (ILit base val) = 
+  case base of
+     8  -> text (showOct val "")
+     16 -> text (showHex val "")
+     10 | val < 0   -> parens (integer val)
+        | otherwise -> integer val
+     _  -> trace ("ppILit: No one told me that base " ++ 
+                  show base ++ " was supported!\n") $
+           integer val
+
+\end{code}
+ src/Main.lhs view
@@ -0,0 +1,424 @@+% 
+% (c) The Foo Project, Universities of Glasgow & Utrecht, 1997-8
+%
+% @(#) $Docid: Jun. 9th 2003  12:58  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+The toplevel driver for the IDL compiler
+
+\begin{code}
+module Main
+       ( main
+       , hdirectHelp
+       ) where
+
+import LexM
+import qualified Parser (parseIDL)
+import qualified OmgParser (parseIDL)
+import Opts
+import PpCore   ( ppCore, showCore, showHeader, ppHeaderDecl )
+import CoreUtils ( getInterfaceIds )
+import PpIDLSyn ( ppIDL, showIDL )
+import IDLSyn   ( Attribute, Defn )
+import IDLUtils ( sortDefns, winnowDefns )
+import CoreIDL  ( Decl )
+import AbstractH  ( HTopDecl(..) )
+import PpAbstractH ( ppHTopDecls, showAbstractH )
+import PreProc
+import Desugar
+import Rename
+import IO  ( hPutStr, hPutStrLn, stderr, stdout, hPutChar,
+	     openFile, IOMode(..), hClose, Handle, hFlush
+	   )
+import Monad  ( when )
+import System (getProgName, exitWith, ExitCode(..) )
+import CodeGen
+import Utils ( dropSuffix, basename, notNull )
+import Time
+import List  ( partition )
+import Version
+import Locale
+import HugsCodeGen
+import DefGen
+import CStubGen
+import JavaProxy
+import Env ( newEnv, addListToEnv_C )
+
+{- BEGIN_SUPPORT_TYPELIBS
+import 
+       TLBWriter
+import 
+       ImportLib
+import 
+       Com   ( coRun )
+   END_SUPPORT_TYPELIBS -}
+{- BEGIN_USE_REGISTRY
+import 
+       Win32Registry  ( hKEY_LOCAL_MACHINE, regQueryValue, regOpenKeyEx, kEY_READ )
+import 
+       StdDIS	      ( MbString )
+   END_USE_REGISTRY -}
+\end{code}
+
+\begin{code}
+main :: IO ()
+main
+ | optVersion  = putStrLn version_msg
+ | optHelp     = do { pgm <- getProgName ; putStrLn (usage_msg pgm) }
+ | otherwise   = do
+{- BEGIN_SUPPORT_TYPELIBS
+   coRun $ do   
+   END_SUPPORT_TYPELIBS -}
+    file <- getInpFile
+    case file of 
+      Nothing     -> do { pgm <- getProgName ; putStrLn (usage_msg pgm) }
+      Just fnames -> do
+	case optOFiles of
+	   (_:_) | length fnames > 1 -> do
+	      pgm <- getProgName
+	      hFlush stdout
+	      hPutStr stderr pgm
+	      hPutStrLn stderr (": you cannot use -o if you have multiple input files")
+	      hPutStrLn stderr (usage_msg pgm)
+	      exitWith (ExitFailure 1)
+	   _ -> do
+	     let
+	       oFileFun | length fnames == 1 = \ n -> (oFile n, oModNm n)
+	                | otherwise          = \ n -> (Right (oFileFromInput n), oModNm n)
+               incls = optincludedirs ++ ["."]
+
+	     if not optTlb 
+	      then do
+	       sequence (map (\ f -> processFile incls f (oFileFun f)) fnames)
+	       return ()
+	      else do
+{- BEGIN_SUPPORT_TYPELIBS
+                ds <- mapM (importLib) fnames
+		let inp = Right ds
+   END_SUPPORT_TYPELIBS -}
+
+{- BEGIN_NOT_SUPPORT_TYPELIBS -}
+		let src     = unlines $ map (\ x -> "importlib(" ++ show x ++ ");") fnames
+		    inp     = Left src
+	        hPutStrLn stderr "WARNING: Type library reading code not compiled in; Ignoring --tlb option"
+{- END_NOT_SUPPORT_TYPELIBS -}
+                let o_fnm   = oFile  (head fnames)
+		    o_modnm = oModNm (head fnames)
+		processSource incls "<typelib>" inp (o_fnm, o_modnm)
+
+ where
+   oModNm _  = case optOutputModules of { (x:_) -> Just x ; _ -> Nothing }
+   oFile nm  = case optOFiles        of { (x:_) -> Left x ; _ -> Right (oFileFromInput nm) }
+
+   oFileFromInput nm =
+     case nm of
+        "-" -> nm
+	_
+	 | optServer -> (dropSuffix nm) ++ "Proxy.hs"
+         | otherwise -> (dropSuffix nm) ++ ".hs"
+
+   getInpFile = 
+         case optFiles of
+            [] -> return Nothing
+            _  -> return (Just (reverse optFiles))
+              
+    
+hdirectHelp :: IO ()
+hdirectHelp = do
+  pgm <- getProgName
+  putStrLn (usage_msg pgm)
+
+\end{code}
+
+\begin{code}
+processFile :: [String] 
+	    -> String
+	    -> (Either String String, Maybe String)
+	    -> IO ()
+processFile path fname ofname = do
+  fname'     <- preProcessFile fname
+  ls         <- 
+     case fname' of
+        "-" -> getContents
+	_   -> readFile fname'
+  processSource path fname (Left ls) ofname
+
+processAsf :: [String] 
+	   -> String
+	   -> IO [(String,Bool,[Attribute])]
+processAsf path fname = do
+  when optVerbose (hFlush stdout >> hPutStrLn stderr ("Processing ASF: " ++ fname))
+  ls         <- 
+     case fname of
+        "-" -> getContents
+	_   -> readFile fname
+  Right x  <- runLexM path fname ('=':ls) Parser.parseIDL
+  return x
+  
+showPassMsg :: String -> IO ()
+showPassMsg msg = do
+  hFlush stdout
+  hPutStrLn stderr ("***" ++ msg)
+  hFlush stderr
+
+processSource :: [String]
+	      -> String
+	      -> Either String [Defn]
+	      -> (Either String String, Maybe String)
+	      -> IO ()
+processSource path fname ls ofname = do
+  when optShowPasses (showPassMsg "Reader")
+  defs <- 
+     case ls of
+       Left str -> 
+          catch 
+             (runLexM path fname str parseIDL)
+	     (\ err -> removeTmp >> ioError err)
+       Right ds -> return ds
+  when (optShowPasses && notNull optAsfs)
+       (showPassMsg "Asf reader")
+  asfs       <- mapM (processAsf path) optAsfs
+  let 
+       {-
+        Definitions are sorted either on the command of 
+	the user, or if we're operating in 'winnow'ing mode.
+       -}
+      s_defs
+       | optWinnowDefns || optSortDefns || optJNI = sortDefns defs
+       | otherwise    			= defs
+
+      w_defs
+       | optWinnowDefns = winnowDefns asf_env s_defs
+       | otherwise      = s_defs
+
+      combineAsf (f1, old) (f2, new) = (f1 && f2, old ++ new)
+
+      asf_env   = addListToEnv_C combineAsf newEnv 
+      				 (map (\ (x,y,z) -> (x, (y,z))) (concat asfs))
+
+      os = showIDL (ppIDL fname w_defs)
+
+  dumpPass dumpIDL     "Parsed IDL" os
+  when optShowPasses (showPassMsg "Desugarer")
+  (core_decls, tenv, tg_env, senv, ifenv) <- desugar fname asf_env w_defs
+  let cs = showCore (ppCore core_decls)
+
+  dumpPass dumpDesugar "Desugared IDL" cs
+
+  let (renamed_decls, iso_env, iface_env) 
+         = renameDecls tenv tg_env senv ifenv core_decls
+      rs = showCore (ppCore renamed_decls)
+
+  dumpPass dumpRenamer "Renamed Core IDL" rs
+  
+  when (optOutputTlb || notNull optOutputTlbTo) 
+{- BEGIN_SUPPORT_TYPELIBS
+       (coRun $ writeTLB optOutputTlbTo renamed_decls)
+   END_SUPPORT_TYPELIBS -}
+{- BEGIN_NOT_SUPPORT_TYPELIBS -}
+       (hPutStrLn stderr "WARNING: type library handling code not compiled in; ignoring --output-tlb= option")
+{- END_NOT_SUPPORT_TYPELIBS   -}
+  when optShowPasses (showPassMsg "CodeGen")
+  let (header, code) = codeGen ofname iso_env iface_env renamed_decls
+      code_str	     = unlines (map showCode code)
+
+  dumpPass dumpAbstractH "Abstract Haskell" code_str
+  when optShowPasses (showPassMsg "CodeOutput")
+  when (optJNI && optServer) (writeJava renamed_decls)
+  writeHeader header
+  let def_files = defGen code
+  when (not optNoOutput && optGenDefs)
+       (sequence_ (map (uncurry writeOutStuff) def_files))
+  when (not optNoOutput) 
+       (writeCode True code)
+  removeTmp
+
+{-  Invoke the right parser. -}
+parseIDL :: LexM [Defn]
+parseIDL
+ | optCompilingOmgIDL = OmgParser.parseIDL 
+ | otherwise	      = Parser.parseIDL >>= \ (Left x) -> return x
+
+\end{code}
+
+Bunch of small helper functions to write out and show code.
+
+\begin{code}
+showCode :: (String, Bool, [HTopDecl]) -> String
+showCode (nm, _, ds) = file_msg (showAbstractH (ppHTopDecls ds))
+ where
+  file_msg cont
+    | generateGreenCard = "File: "++ show (dropSuffix nm ++ ".gc") ++ '\n':cont
+    | otherwise		= "File: "++ show nm ++ '\n':cont
+
+generateGreenCard :: Bool
+generateGreenCard = not optNoOutput && optGreenCard
+
+writeCode :: Bool -> [(String, Bool, [HTopDecl])] -> IO ()
+writeCode _          []                 = return ()
+writeCode is_haskell ((nm, flg, md):rs) = do
+  writeOutCode
+  when (is_haskell && flg) $ do
+        hFlush stdout
+        hPutStrLn stderr 
+		  ("Notice: Need to generate C stubs as well for module " ++ show (dropSuffix nm) ++ ",")
+	hPutStrLn stderr
+	          ("        since it contains methods that passes structs/unions")
+	hPutStrLn stderr
+	          ("        by value.")
+  when (not optNoOutput && is_haskell && (optHugs || optGenCStubs || flg))
+       (writeCode False [(nm,flg,md)])
+  writeCode is_haskell rs
+ where
+  writeOutCode  = writeOut incs is_haskell False out_nm (showDecls non_incs)
+
+  showDecls
+    | is_haskell   = showAbstractH.ppHTopDecls
+    | not optHugs  = cStubGen out_nm
+    | otherwise    = hugsCodeGen out_nm
+
+  incs             = map (\ (HInclude s) -> s) incs'
+  (incs',non_incs) = partition filterIncludes md
+  
+  filterIncludes HInclude{}     = is_haskell -- C'ish backends deal with 
+  					     -- the includes directly.
+  filterIncludes _              = False
+
+  out_nm = 
+   case nm of
+     "-" -> nm
+     _ 
+      | generateGreenCard -> dropSuffix nm ++ ".gc"
+      | not is_haskell    -> dropSuffix nm ++ ".c"
+      | otherwise	  -> nm
+
+writeOut :: [String] -> Bool -> Bool -> String -> String -> IO ()
+writeOut _    _          _       _             "" = return ()
+writeOut incs is_haskell no_hdrs fname_prim stuff = do
+  when (optVerbose && fname /= "-") (hFlush stdout >> hPutStr stderr ("Writing " ++ fname))
+  case fname of
+    "-" -> do
+      hPutBanner embed_comment stdout
+      includes_at_top stdout
+      putStrLn stuff
+    _   -> do
+      hp <- openFile fname WriteMode
+      when is_haskell       (includes_at_top hp)
+      hPutBanner embed_comment hp
+      when (not is_haskell) (includes_at_top hp)
+      hPutStrLn hp stuff
+      hClose hp
+  when optVerbose (hFlush stdout >> hPutChar stderr '\n')
+ where
+   fname = 
+    case fname_prim of
+      "-" -> fname_prim
+      _   ->
+        case optODirs of
+         (x:_) -> x ++ '/':basename fname_prim
+         _     -> fname_prim
+
+   dirs 
+     | no_hdrs    = incs
+     | is_haskell = optIncludeHeaders ++ incs
+     | otherwise  = optIncludeCHeaders ++ optIncludeHeaders ++ incs
+
+   embed_comment ls
+    | is_haskell = unlines (map (\ x -> '-':'-':' ':x) ls)
+    | otherwise  = block_comment ls ++
+    		   unlines
+		     [ ""
+		     , if optHugs then "#include \"HDirect.h\"" else ""
+		     , "#ifndef __INT64_DEFINED__"
+		     , "#ifdef __GNUC__"
+		     , "typedef long long int64;"
+		     , "typedef unsigned long long uint64;"
+		     , "#else"
+		     , "#ifdef _MSC_VER"
+		     , "typedef __int64 int64;"
+		     , "typedef unsigned __int64 uint64;"
+		     , "#else"
+		     , "/* Need some help here, please. */"
+		     , "#endif"
+		     , "#endif"
+		     , "#define __INT64_DEFINED__"
+		     , "#endif"
+		     , ""
+		     ]
+
+   includes_at_top hp
+     | null dirs || optGreenCard = return ()
+     | otherwise = do
+            -- one {-# OPTIONS ... #-} per include file.
+           sequence (map (gen_options hp) dirs)
+	   return ()
+
+   gen_options hp hfile = 
+       case hfile of
+          []     -> return ()
+	  _      -> hPutStrLn hp (gen_include (showFn hfile))
+           where
+	    gen_include fn
+	      | is_haskell = "{-# OPTIONS -#include " ++ fn ++ " #-}"
+	      | otherwise  = "#include " ++ fn
+
+            showFn ls@('"':_) = ls
+            showFn ls@('<':_) = ls
+	    showFn ls	      = show ls
+
+hPutBanner :: ([String] -> String) -> Handle -> IO ()
+hPutBanner comment hp = do
+  ls <- mkBanner comment 
+  hPutStrLn hp ls
+
+mkBanner :: ([String] -> String) -> IO String
+mkBanner comment = do
+  cal <- getClockTime >>= toCalendarTime
+  let date = formatCalendarTime defaultTimeLocale "%H:%M %Z, %A %d %B, %Y" cal
+  return (comment
+      [ "Automatically generated by " ++ pkg_name ++ ", " ++ pkg_version
+      , "Created: " ++ date
+      , "Command line: " ++ unwords theOpts
+      ])
+
+block_comment :: [String] -> String
+block_comment ls = unlines ("/*":ls ++ ["*/"])
+
+writeOutStuff :: String -> String -> IO ()
+writeOutStuff fname stuff = do
+  when optVerbose (hFlush stdout >> hPutStr stderr ("Writing " ++ fname))
+  hp <- openFile fname WriteMode
+  hPutStrLn hp stuff
+  hClose hp
+  when optVerbose (hPutChar stderr '\n')
+
+writeHeader :: [(String, Decl)] -> IO ()
+writeHeader ls = do
+   sequence (map (\ (fname, d) -> 
+   		    writeOut [] False True
+		             fname
+			     (showHeader fname (ppHeaderDecl (getInterfaceIds d) d)))
+		 ls)
+   return ()
+
+writeJava :: [Decl] -> IO ()
+writeJava ds = do
+   sequence (map (\ (fname, d) -> do
+                        b <- mkBanner block_comment
+   			writeOutStuff (dropSuffix fname ++ ".java")
+   						(b ++ javaProxyGen d))
+		 ls)
+   return ()
+ where
+  ls = prepareDecls ds
+
+dumpPass :: Bool -> String -> String -> IO ()
+dumpPass True hdr stuff =
+  case optOutputDumpTo of
+    Nothing -> do
+      putStrLn ("**** " ++ hdr ++ " ****")
+      hPutStrLn stdout stuff
+    Just x  -> writeFile x stuff
+dumpPass False _ _ = return ()
+\end{code}
+ src/Makefile view
@@ -0,0 +1,162 @@+# -----------------------------------------------------------------------------
+#
+TOP = ..
+include $(TOP)/mk/boilerplate.mk
+
+# Note: might be overridden from cmd-line (see install rule below)
+INSTALLING=0
+
+#
+# Win32-specific - set this variable to YES if you want to include COM
+# type-library reading/writing code
+# (that code depends on the 'com' package, so if you're bootstrapping,
+# you can't enable SUPPORT_TYPELIBS first-time around).
+#SUPPORT_TYPELIBS=YES
+
+#
+# Win32 specific - set this variable to YES if you want the IDL compiler
+# to consult HKLM\Software\Haskell\HaskellDirect\\<version>\\Options for
+# the default set of options to use. Rarely enabled.
+#USE_REGISTRY=YES
+
+all ::
+
+SRC_HC_OPTS  += -fglasgow-exts -static -fvia-C -Rghc-timing -Wall -recomp
+SRC_HC_OPTS  += -package lang
+
+
+# The end-product.
+HS_PROG   = ihc$(exeext)
+
+BOOT_SRCS = Parser.hs Version.hs OmgParser.hs NativeInfo.hs
+REAL_SRCS = $(wildcard *.lhs) CustomAttributes.hs
+HS_SRCS   = $(REAL_SRCS) $(BOOT_SRCS)
+HS_OBJS   = $(addsuffix .o,$(basename $(HS_SRCS))) ErrorHook.o
+
+SRC_DIST_FILES += $(REAL_SRCS) $(BOOT_SRCS)
+SRC_DIST_FILES += Makefile .depend mkNativeInfo.c Parser.y OmgParser.y ErrorHook.c
+
+
+#
+# Compiling Happy-generated parsers with -Wall is a little bit too noisy..
+#
+silent_opts+=-fno-warn-incomplete-patterns  -fno-warn-missing-signatures
+silent_opts+=-fno-warn-unused-binds -fno-warn-name-shadowing
+silent_opts+=-fno-warn-unused-matches
+
+cond_opts+= -cpp -DBEGIN_GHC_ONLY='-}' -DEND_GHC_ONLY='{-'
+cond_opts+= -DBEGIN_NOT_FOR_GHC='{-' -DEND_NOT_FOR_GHC='-}' -DELSE_FOR_GHC='-}-}' 
+
+
+Parser_HC_OPTS      = -Onot $(cond_opts) $(silent_opts)
+OmgParser_HC_OPTS   = -Onot $(cond_opts) $(silent_opts)
+
+PreProc_HC_OPTS     += $(cond_opts)
+Utils_HC_OPTS       += $(cond_opts)
+BasicTypes_HC_OPTS  += $(cond_opts)
+CoreUtils_HC_OPTS   += $(cond_opts)
+CoreIDL_HC_OPTS     += $(cond_opts)
+
+Parser_HAPPY_OPTS   += -g +RTS -H6m -RTS
+SRC_HSTAGS_OPTS     += -fglasgow-exts
+
+
+ifeq "$(SUPPORT_TYPELIBS)" "YES"
+Typelib_opts+= -cpp -DBEGIN_SUPPORT_TYPELIBS='-}' -DEND_SUPPORT_TYPELIBS='{-'
+Typelib_opts+= -DBEGIN_NOT_SUPPORT_TYPELIBS='{-' -DEND_NOT_SUPPORT_TYPELIBS='-}'
+
+ImportLib_HC_OPTS    += $(Typelib_opts)
+Main_HC_OPTS         += $(Typelib_opts)
+TLBWriter_HC_OPTS    += $(Typelib_opts)
+Desugar_HC_OPTS      += $(Typelib_opts)
+TypeInfo_HC_OPTS     += $(Typelib_opts)
+MarshallAuto_HC_OPTS += $(Typelib_opts)
+Opts_HC_OPTS         += $(Typelib_opts)
+
+SRC_MKDEPENDHS_OPTS  += $(Typelib_opts)
+
+# If you don't have the COM support libraries installed as a GHC
+# package [see the install-pkg rule in comlib/Makefile if you want
+# to add this package, but don't know how to], uncomment the next
+# line (and comment out the line following.)
+#SRC_HC_OPTS += -i../lib -L../lib -lole32 -loleaut32 -ladvapi32
+SRC_HC_OPTS          += -package com
+
+else
+ImportLib_HC_OPTS    += -cpp
+endif
+
+Main_HC_OPTS         += -cpp 
+TLBWriter_HC_OPTS    += -cpp
+
+
+ifeq "$(USE_REGISTRY)" "YES"
+Registry_opts   += -cpp -DBEGIN_USE_REGISTRY='-}' -DEND_USE_REGISTRY='{-'
+Registry_opts   += -DBEGIN_NOT_USE_REGISTRY='{-' -DEND_NOT_USE_REGISTRY='-}'
+Registry_opts   += -package win32
+
+Main_HC_OPTS    += $(Registry_opts)
+Opts_HC_OPTS    += $(Registry_opts)
+SRC_LD_OPTS	+= -package win32 -ladvapi32
+endif
+
+# Package setup
+PKG_NAME    = HaskellDirect ($(HS_PROG))
+
+ifeq "$(MajorRelease)" "YES"
+PKG_VERSION = version $(PACKAGE_VERSION)
+else
+PKG_VERSION = snapshot $(shell date +%d%m%y)
+endif
+
+# Don't want mkNativeInfo.o included.
+OBJS    := $(HS_OBJS)
+
+# Make sure Version.hs and NativeInfo.hs doesn't get nuked.
+.PRECIOUS: %.hs
+
+boot :: mkVersion
+boot :: $(BOOT_SRCS)
+
+dist :: mkVersion
+
+.PHONY: mkVersion
+
+GHCMAKE_OPTS = $(HC_OPTS) -cpp
+
+ghcmake :: $(BOOT_SRCS) Version.hs
+	$(HC) --make $(GHCMAKE_OPTS) $(HS_SRCS)
+
+mkVersion :
+	$(RM) Version.hs
+	echo "--Automatically generated"         > Version.hs
+	echo "module Version where"             >> Version.hs
+	echo ""				        >> Version.hs
+	echo "pkg_name :: String"               >> Version.hs
+	echo "pkg_name    = \"$(PKG_NAME)\""    >> Version.hs
+	echo "pkg_version :: String"            >> Version.hs
+	echo "pkg_version = \"$(PKG_VERSION)\"" >> Version.hs
+
+NativeInfo.hs : mkNativeInfo
+	$(RM) $@
+	./mkNativeInfo > $@ || ( rm $@ && exit 1 )
+
+C_PROG = mkNativeInfo
+
+ErrorHook.o : ErrorHook.c
+	$(HC) -c $< -o $@
+
+clean-tlbs:
+	$(RM) Opts.o Main.o ImportLib.o TLBWriter.o TypeInfo.o
+
+
+#
+# Install setup
+#
+INSTALL_PROGS=$(HS_PROG)
+
+install :: install-dirs
+
+include $(TOP)/mk/target.mk
+Parser.hs : Parser.y
+OmgParser.hs : OmgParser.y
+ src/MarshallAbstract.lhs view
@@ -0,0 +1,187 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 9th 2003  06:49  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+<tt/MarshallAbstract/ generates the stubs for IDL types
+that are to be represented as abstract Haskell types. These
+abstract types are only generated when in 'Haskell-2-C' mode
+for (empty?) interface declarations.
+
+\begin{code}
+module MarshallAbstract ( marshallAbstract ) where
+
+import MarshallType
+import CgMonad
+
+import BasicTypes ( QualName, qName, CallConv(..)  )
+import Literal    ( Literal(..)  )
+import AbstractH  ( HDecl )
+import AbsHUtils
+import LibUtils
+import Opts       ( optHugs )
+
+import Attribute
+
+import CoreIDL
+import CoreUtils  ( mkHaskellTyConName, addrTy )
+
+\end{code}
+
+
+\begin{code}
+marshallAbstract :: Id -> CgM HDecl
+marshallAbstract i = do
+  ds <- mapM exportify decl_list
+  return (andDecls ds)
+  where
+    decl_list  = 
+     (if isFinalised then
+        ( ( fin_name, fin_decl ) :)
+      else
+        id) $
+     (if isFinalised then
+        id  -- ToDo: generate one (it's genuinely useful in some cases.)
+      else 
+        ( ( f_name, f_tysig `andDecl`  f_def) :)) 
+     [ ( m_name, m_tysig `andDecl`  m_def)
+     , ( u_name, u_tysig `andDecl`  u_def)
+     , ( w_name, w_tysig `andDecl`  w_def)
+     , ( r_name, r_tysig `andDecl`  r_def)
+     , ( s_name, s_tysig `andDecl`  s_def)
+     , ( l_name, l_tysig `andDecl`  l_def)
+     ]
+
+    exportify (nm, d) = do
+      addExport (ieValue nm)
+      return d
+
+    attrs       = idAttributes i
+    isFinalised = attrs `hasAttributeWithName` "finaliser"
+    
+    free_routine =
+      case findAttribute "free" attrs of
+        Just (Attribute _ [ParamLit (StringLit s)]) -> mkVarName s
+        _ -> LibUtils.free
+
+    abs_nm     = idOrigName i
+    con_name   = mkHaskellTyConName abs_nm
+    name       = mkVarName con_name
+
+    fin_name  = finaliser
+    fin_decl  
+      | optHugs   = prim Cdecl (dname, Nothing, orig_fin_nm, Nothing)
+                         fin_name (tyFunPtr (funTy (tyPtr t_ty) io_unit))
+		         False [] (False,"void*")
+      | otherwise = extLabel orig_fin_nm fin_name (tyFunPtr (funTy (tyPtr t_ty) io_unit))
+      where
+       dname = "" -- dll location.
+
+    (finaliser, orig_fin_nm) = 
+       case (findAttribute "finaliser" attrs) of
+          Just (Attribute _ [ParamLit (StringLit s)]) -> ("addrOf_" ++ idName i ++ '_':s, s)
+	  _ -> let s = "no-finaliser" in (s,s)
+
+    ty_args  = 
+     case findAttribute "ty_args" attrs of
+      Just (Attribute _ [ParamLit (StringLit s)]) -> map tyVar (words s)
+      _ -> []
+
+    v          = var "v"
+    vptr       = var "ptr"
+    t_ty       = tyCon con_name ty_args
+
+    prim_ty    = tyPtr t_ty
+    b_ty
+     | isFinalised = tyForeignPtr t_ty
+     | otherwise   = prim_ty
+
+    -- ** Marshalling ** --
+    m_name     = qName (prefix marshallPrefix name)
+    m_tysig    = typeSig m_name (funTy t_ty (io b_ty))
+    m_def      = funDef m_name [conPat (mkConName con_name) [varPat v]] m_rhs
+    m_rhs      = ret v
+
+    -- ** unmarshalling ** --
+    u_name     = qName (prefix unmarshallPrefix name)
+    u_tysig    = typeSig u_name u_type
+    u_type
+      | isFinalised = funTy tyBool (funTy prim_ty (io t_ty))
+      | otherwise   = (funTy prim_ty (io t_ty))
+
+    u_def      = funDef u_name u_pats u_rhs
+    u_pats 
+      | isFinalised = [patVar "finaliseMe__", varPat v]
+      | otherwise   = [varPat v]
+    u_rhs
+      | isFinalised =
+           bind (funApp mkForeignObj [v, hCase (var "finaliseMe__") 
+	   				       [alt (conPat false []) (varName nullFinaliser)
+					       ,alt (conPat true [])  (var finaliser)
+					       ]]) v $
+           ret (dataCon (mkConName con_name) [v])
+      | otherwise =
+           ret (dataCon (mkConName con_name) [v])
+    
+    -- ** Reference marshalling 
+    w_name   = qName (prefix marshallRefPrefix name)
+    w_tysig  = typeSig w_name w_ty
+    w_ty     = funTy (tyPtr (tyPtr t_ty)) (funTy t_ty io_unit)
+    w_def    = funDef w_name [ varPat vptr
+			     , conPat (mkConName con_name) [varPat v]] w_rhs
+    w_rhs
+      | isFinalised = funApp w_fptr [vptr , v]
+      | otherwise   = funApp w_ptr  [vptr , v]
+    
+    -- ** Reference unmarshalling 
+    r_name   = qName (prefix unmarshallRefPrefix name)
+    r_tysig  = typeSig r_name r_ty
+    r_ty 
+      | isFinalised = funTy tyBool (funTy (tyPtr t_ty) (io t_ty))
+      | otherwise   = funTy (tyPtr t_ty) (io t_ty)
+    r_def    = funDef r_name r_pats r_rhs
+    r_pats
+      | isFinalised = [patVar "finaliseMe__", varPat vptr]
+      | otherwise   = [varPat vptr]
+    r_rhs
+      | isFinalised =
+           bind (funApp r_ptr [vptr]) v $
+           bind (funApp mkForeignObj [v, hCase (var "finaliseMe__") 
+	   				       [alt (conPat false []) (varName nullFinaliser)
+					       ,alt (conPat true [])  (var finaliser)
+					       ]]) v $
+	   ret (dataCon (mkConName con_name) [v])
+      | otherwise   = 
+           bind (funApp r_ptr  [vptr]) v $
+	   ret (dataCon (mkConName con_name) [v])
+
+    f_name   = qName (prefix freePrefix name)
+    f_tysig  = typeSig f_name (funTy t_ty io_unit)
+    f_def    = funDef f_name [conPat (mkConName con_name) [varPat v]] f_rhs
+    f_rhs    = funApp free_routine [v]
+    s_name   = qName (prefix sizeofPrefix name)
+--     s_name   = sizeOfName
+    s_tysig  = typeSig s_name tyWord32
+    s_def    = funDef s_name [] s_rhs
+    s_rhs    = szType addrTy
+
+    -- addr --> ADT-type lifting fun.
+
+    l_name   = qName (prefix "addrTo" name)
+    l_tysig  = typeSig l_name (funTy anyTyPtr t_ty)
+    l_def    = funDef l_name [varPat v] l_rhs
+    l_rhs
+      | isFinalised =
+        funApp (mkQVarName ioExts "unsafePerformIO")
+           [bind (funApp mkForeignObj [castPtr v, var finaliser]) v $
+            ret (dataCon (mkConName con_name) [v])]
+      | otherwise =
+           dataCon (mkConName con_name) [castPtr v]
+
+    w_ptr    = prefix marshallRefPrefix (mkQVarName hdirectLib ptrName)
+    r_ptr    = prefix unmarshallRefPrefix (mkQVarName hdirectLib ptrName)
+    w_fptr   = prefix marshallRefPrefix (mkQVarName hdirectLib fptr)
+
+\end{code}
+ src/MarshallAuto.lhs view
@@ -0,0 +1,223 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Mar. 31th 2003  08:37  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Support for generating client stubs for Automation interfaces.
+
+\begin{code}
+module MarshallAuto
+       (
+         marshallVariantParam
+       , unmarshallVariantParam
+       , marshallVariant
+       , classifyCall
+       , permissibleAutoSig
+       ) where
+
+import qualified AbstractH as Haskell
+import AbsHUtils
+import MarshallType ( coreToHaskellExpr )
+import MarshallCore ( toBaseTy, autoTypeToQName, mbAutoTypeToHaskellTy )
+import CoreIDL
+import CoreUtils ( int32Ty, doubleTy, mkHaskellVarName, 
+		   isHRESULTTy, isVoidTy, boolTy
+		 )
+
+import BasicTypes
+import Attribute ( hasAttributeWithName, findAttribute )
+import LibUtils ( autoLib )
+import Opts  ( optOptionalAsMaybe
+	     )
+import Maybe ( isJust )
+import Literal
+
+\end{code}
+
+
+\begin{code}
+marshallVariantParam :: Param -> Haskell.Expr
+marshallVariantParam p = funApply real_marshaller [ var (idName (paramId p)) ]
+ where
+  m = paramMode p
+
+  attrs = idAttributes (paramId p)
+
+   -- taking [defaultvalue()]s into account (if any).
+   -- Use 'marshallerMeth' if you don't care for this stuff.
+  real_marshaller
+   | m == In && attrs `hasAttributeWithName` "defaultvalue" = 
+      case findAttribute "defaultvalue" attrs of
+        Just (Attribute _ (ap:_))
+	     | okLooking ap -> 
+		    let
+		      pt      = paramType p
+		      base_ty = toBaseTy pt
+			{-
+			  Stuff like
+			    [in,optional,defaultvalue(0)]IUnknown* ip
+			    [in,optional,defaultvalue(0)]char ip
+			  
+			  won't work if we use the arg type to drive
+			  marshalling, so catch this sep.
+			-}
+		      the_base_ty
+		       | isIntLit expr    = int32Ty
+		       | isBoolLit expr   = boolTy
+		       | isDoubleLit expr = doubleTy
+		       | otherwise        = base_ty
+		       
+		      def_val_marshaller
+		       | not optOptionalAsMaybe = qvar autoLib "inDefaultValue"
+		       | otherwise		= qvar autoLib "inMaybe"
+                    in		       
+		       funApply def_val_marshaller
+			        [ funApply (marshallVariant kind the_base_ty)
+					   [coreToHaskellExpr expr]
+				, marshallerMeth
+				]
+	    where
+	     okLooking (ParamLit  _) = True
+	     okLooking (ParamExpr _) = True
+	     okLooking _	     = False
+	     
+	     isIntLit e = 
+	        case e of
+		  Lit (IntegerLit{}) -> True
+		  _		     -> False
+
+	     isDoubleLit e = 
+	        case e of
+		  Lit (FloatingLit{}) -> True
+		  _		      -> False
+
+	     isBoolLit e = 
+	        case e of
+		  Lit (BooleanLit{}) -> True
+		  _		     -> False
+
+	     expr = 
+	       case ap of
+	         ParamLit  l -> Lit l
+		 ParamExpr e -> e
+		 _           -> error "MarshallAuto.marshallVariantParam.expr: unexpected parameter kind"
+
+        _ 
+	  | optOptionalAsMaybe ->
+		       funApply (qvar autoLib "inMaybe")
+			        [ qvar autoLib "noInArg"
+				, marshallerMeth
+				]
+	      
+	  | otherwise  -> marshallerMeth
+
+   | has_optional && optOptionalAsMaybe =
+       funApply (qvar autoLib "inMaybe")
+	        [ qvar autoLib "noInArg"
+		, marshallerMeth
+		]
+   | otherwise = marshallerMeth
+
+  marshallerMeth
+   | m == In && not optOptionalAsMaybe && has_optional = qvar autoLib "inVariant"
+   | otherwise = marshallVariant kind (paramOrigType p)
+     
+  has_optional = attrs `hasAttributeWithName` "optional"
+
+  kind =
+   case m of
+     In    -> "in"
+     Out   -> "out"
+     InOut -> "inout"
+
+unmarshallVariantParam :: Param -> Haskell.Expr
+unmarshallVariantParam p = 
+  case m of
+    InOut -> funApply expr [var (mkHaskellVarName (idName (paramId p)))]
+    _     -> expr
+ where
+  expr = marshallVariant kind (paramType p)
+  m    = paramMode p
+  kind =
+   case m of
+     In    -> "in"
+     Out   -> "out"
+     InOut -> "inout"
+
+marshallVariant :: String -> Type -> Haskell.Expr
+marshallVariant pre ty = 
+   let 
+    qn = autoTypeToQName ty
+    qv = prefix pre qn
+   in
+   qvar autoLib (qName qv)
+
+\end{code}
+ 
+determine what kind of Automation library stub to call.
+ 
+\begin{code}
+classifyCall :: Id -> Bool -> [Param] -> Result -> Haskell.VarName
+classifyCall f useDISPID ps res
+  | isPropGet      = mkQVarName autoLib ("propertyGet" ++ prop_arity ++ dispid)
+  | isPropPutWeird = mkQVarName autoLib ("propertySetGet" ++ dispid)
+  | isPropPut      = mkQVarName autoLib ("propertySet" ++ dispid)
+  | otherwise      = mkQVarName autoLib (kind ++ dispid ++ arity_str)
+  where
+   kind
+    | any hasRetValAttr ps ||
+      (not (isHRESULTTy res_ty) && not (isVoidTy r_ty) &&
+       all isInParam ps ) = "function"
+    | otherwise = "method"
+
+   dispid
+    | useDISPID = "ID"
+    | otherwise = ""
+
+   r_ty   = resultType res
+   res_ty = resultOrigType res
+
+   hasRetValAttr p =
+     (idAttributes (paramId p)) `hasAttributeWithName` "retval"
+
+   attrs     = idAttributes f
+
+   isPropPutWeird = isPropPut &&
+		    any (\ p -> paramMode p == InOut) ps
+
+   isInParam p = paramMode p == In
+
+   isPropGet = attrs `hasAttributeWithName` "propget"
+   isPropPut = attrs `hasAttributeWithName` "propput"    ||
+               attrs `hasAttributeWithName` "propputref"
+
+   prop_arity
+     | arity <= (1::Int) = ""
+     | otherwise	 = arity_str
+
+   arity_str = show arity
+
+   arity =
+    case res_ty of
+      Name "HRESULT" _ _ _ _ _ -> arity'
+      Void -> arity'
+      _    -> arity' + 1
+    where
+     arity' = length (filter isOutParam ps)
+
+   isOutParam p = pm == Out || pm == InOut
+     where pm = paramMode p
+
+\end{code}
+
+\begin{code}
+permissibleAutoSig :: Result -> [Param] -> Bool
+permissibleAutoSig res ps = 
+  (isVoidTy r_ty || isHRESULTTy r_ty || isJust (mbAutoTypeToHaskellTy In r_ty)) &&
+  all isJust (map ((mbAutoTypeToHaskellTy In).paramType) ps)
+ where
+  r_ty = resultType res
+
+\end{code}
+ src/MarshallCore.lhs view
@@ -0,0 +1,788 @@+%
+% (c) The Foo Project, University of Glasgow, 1999
+%
+% @(#) $Docid: Dec. 9th 2003  09:07  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Higher-level marshalling code - working over Core IDL 
+constructs. (That's the Official Line - the Real Reason
+for this module is that it avoids creating a mutual
+dependency between MarshallType and MarshallDep.)
+
+\begin{code}
+module MarshallCore
+       (
+         toHaskellMethodTy
+       , toHaskellTy
+       , paramToHaskellType
+
+       , mkHStructDef
+       , mkHEnumDef
+       , mkHUnionDef
+       , mkCUnionDef
+
+       , toHaskellBaseTy
+       , toBaseTy
+       , toHaskellBaseMethodTy
+
+       , mkMarshaller
+       
+       , autoTypeToHaskellTy
+       , autoTypeToQName
+       , mbAutoTypeToHaskellTy
+       
+       , constrainIIDParams
+       
+       ) where
+
+import qualified AbstractH as Haskell ( Type, ConDecl, Context )
+import AbsHUtils
+
+import CoreIDL
+import CoreUtils
+
+import MarshallUtils
+
+import BasicTypes
+import Attribute
+import Literal
+import LibUtils
+import PpCore
+import Utils    ( notNull, trace )
+import Opts
+import TypeInfo ( TypeInfo(..) )
+
+import Maybe
+import List     ( nub )
+
+\end{code}
+
+Converting a interface method signature into its corresponding 
+Haskell type. This means taking into consideration the presence
+of [out] parameters plus dependent arguments etc.
+
+\begin{code}
+toHaskellMethodTy :: Bool
+		  -> Bool
+		  -> Bool
+	          -> Maybe Haskell.Type
+		  -> [Param]
+		  -> Result
+		  -> (Haskell.Type, Maybe Haskell.Context)
+toHaskellMethodTy isPure isServer isAuto mb_iface_ty params result 
+  = case generaliseTys (mb_io_res_ty: the_param_tys) of
+     ((r:ps), mb_c) -> (funTys ps r, mb_c)
+     _              -> error "MarshallCore.toHaskellMethodTy: unexpected result"		       
+  where
+   mb_io_res_ty
+     | isPure    = the_res_ty
+     | otherwise = io the_res_ty
+     
+   (pars, _, _, _,res)     = binParams params
+   (real_params, par_deps) = findParamDependents False pars
+   (_, res_deps)           = findParamDependents False res
+
+   the_param_tys =
+     case mb_iface_ty of
+       Nothing -> param_tys
+       Just x  -> param_tys ++ [x]
+
+   (param_tys, res_tys) = 
+       constrainIIDParams (paramToHaskellType par_deps isServer isAuto False)
+       			  (paramToHaskellType res_deps isServer isAuto True)
+			  real_params
+			  res_params
+
+   res_params = removeDependees res_deps res
+
+   the_res_ty =
+     tuple (
+      case (resultOrigType result) of
+	t  | isHRESULTTy t && not optKeepHRESULT -> res_tys
+	   | not (isVoidTy (removeNames t)) -> (res_tys ++ [toHaskellTy False (resultOrigType result)])
+	   | otherwise   -> res_tys)
+     
+
+constrainIIDParams :: (Param -> Haskell.Type)
+		   -> (Param -> Haskell.Type)
+		   -> [Param]
+		   -> [Param]
+		   -> ([Haskell.Type], [Haskell.Type])
+constrainIIDParams paramToType resultToType params res 
+  | optUseIIDIs = (param_tys, res_tys)
+  | otherwise   = (param_tys_vanilla, res_tys_vanilla)
+ where
+   toIIDTyVar p ty = 
+      case lookup (idName (paramId p)) iidIs_vars of
+       Just x -> replaceTyVar (mkTyCon iUnknown [uniqueTyVar ('i':show x)]) ty
+       _      -> toIIDTyVarRes p ty
+
+   toIIDTyVarRes p ty =
+       case findAttribute "iid_is" (idAttributes (paramId p)) of
+	  Just (Attribute _ [ParamVar v]) -> 
+	     case lookup v iidIs_vars of
+	        Just x -> replaceTyVar (uniqueTyVar ('i':show x)) ty
+		_ -> ty
+          _ -> ty
+	    
+   iidIs_vars = zip (nub (catMaybes (map isIIDDep res)))
+   		    [(0::Int)..]
+     where
+      isIIDDep p = 
+        case findAttribute "iid_is" (idAttributes (paramId p)) of
+	  Just (Attribute _ [ParamVar v]) -> Just v
+	  _ -> Nothing
+
+   param_tys = zipWith toIIDTyVar    params param_tys_vanilla
+   res_tys   = zipWith toIIDTyVarRes res    res_tys_vanilla
+   
+   param_tys_vanilla = map paramToType  params
+   res_tys_vanilla   = map resultToType res
+
+\end{code}
+
+@toHaskellTy@ takes care of implementing the T[] translation scheme. It differs
+from @toHaskellBaseTy@ in that we're mapping to the user-level representation
+of the IDL type in Haskell, not the type of its marshalled/packed representation.
+
+\begin{code}
+toHaskellTy :: Bool -> Type -> Haskell.Type
+toHaskellTy isGround ty =
+ case ty of
+   Integer sz s    -> mkIntTy sz s
+   Float sz        -> mkFloatTy sz
+   Char signed
+     | optJNI      -> tyWord16
+     | otherwise   -> mkCharTy signed
+   WChar           -> tyWChar
+   Bool            -> tyBool
+   Void            -> tyUnit
+   Octet           -> tyWord8
+   Any             -> tyAddr
+   Object          -> tyAddr
+   StablePtr	   -> tyStable
+   FunTy _ res ps  -> 
+   	case (toHaskellMethodTy False isGround False Nothing ps res') of
+	  (t, Nothing) -> t
+	  (t, Just c)  -> ctxtTyApp c t
+     where
+      res' = res{ resultType     = removePtr (resultType res)
+	        , resultOrigType = removePtr (resultOrigType res)
+	        }
+ 
+   String _ isUnique _ -> (if isUnique then tyMaybe else id) tyString
+   WString isUnique _  -> (if isUnique then tyMaybe else id) tyWString
+   Sequence t _ _      -> tyList (toHaskellTy isGround t)
+   Fixed{}             -> error "not implemented yet."
+   Name _ _ _ _ (Just o@Iface{}) _ -> toHaskellTy isGround o
+   Name _ _ _ _ _ (Just ti) ->
+   	case mkTyConst (haskell_type ti) of
+	   t | optCom && isTyVar t -> 
+			if isGround then
+			   mkTyConst vARIANT
+			else
+			   ctxtTyApp (ctxtClass variantClass [t]) t
+	     | otherwise           -> t
+   Name nm _ md _ _ _ -> tyQConst (fmap mkHaskellTyConName md) (mkHaskellTyConName nm)
+   SafeArray t 
+     | isGround  -> mkTyConst sAFEARRAY
+     | otherwise -> tyQCon autoLib "SafeArray" [toHaskellTy isGround t]
+   Array Void _ -> tyList (toHaskellTy isGround (Pointer Ptr True Void))
+   Array t _ 
+     | optJNI    -> mkTyCon jArray [toHaskellTy isGround t]
+     | otherwise -> tyList (toHaskellTy isGround t)
+
+   Pointer Unique isExp (Iface nm md _ _ _ _)
+     | optCom && isExp -> tyQCon prelude "Maybe" [tyQCon md nm [mkTyConst groundInterface]]
+     | optCom          -> tyQCon md nm [iface_ptr_ty_arg]
+{-
+   Pointer Unique isExp (Iface nm mod _ attrs _ _) 
+     | optJNI && attrs `hasAttributeWithName` "jni_iface_ty" -> 
+     	        let i = tyVar "a" in
+		mkTyCon jObject
+			[ ctxtTyApp (ctxtClass (mkQualName mod nm) [mkTyCon jObject [i]]) i]
+
+     | optSubtypedInterfacePointers -> 
+		     -- Pointer to anything interface'ish is an interface pointer. Period.
+                     tyQCon prelude "Maybe" [tyQCon mod nm [mkTyConst groundInterface]]
+		     --tyQCon mod nm [iface_ptr_ty_arg]
+     | otherwise		    -> tyQCon prelude "Maybe" [tyQConst mod nm]
+-}
+{- moved down
+   Pointer _ isExp (Iface nm mod _ attrs _ _)
+     | optCorba         -> tyQCon  mod nm [iface_ptr_ty_arg]
+	-- what's the IU/ID bit? Needed for processing AutoPrim.idl without
+	-- a hitch. ToDo: remove it.
+     | optHaskellToC && not (nm `elem` ["IUnknown", "IDispatch"]) -> tyQConst mod nm
+     | optJNI && attrs `hasAttributeWithName` "jni_iface_ty" -> 
+     	        let i = tyVar "a" in
+		mkTyCon jObject
+			[ ctxtTyApp (ctxtClass (mkQualName mod nm) [mkTyCon jObject [i]]) i ]
+     | optSubtypedInterfacePointers -> tyQCon  mod nm [iface_ptr_ty_arg]
+     | otherwise		    -> tyQConst mod nm
+-}
+   Pointer Unique _ (Iface nm md _ attrs _ _) 
+     | optJNI && attrs `hasAttributeWithName` "jni_iface_ty" -> 
+     	        let i = tyVar "a" in
+		mkTyCon jObject
+			[ ctxtTyApp (ctxtClass (mkQualName md nm) [mkTyCon jObject [i]]) i]
+
+     | optSubtypedInterfacePointers -> 
+		     -- Pointer to anything interface'ish is an interface pointer. Period.
+                     tyQCon prelude "Maybe" [tyQCon md nm [mkTyConst groundInterface]]
+		     --tyQCon md nm [iface_ptr_ty_arg]
+     | otherwise		    -> tyQCon prelude "Maybe" [tyQConst md nm]
+   Pointer _ _ (Iface nm md _ attrs _ _)
+     | optCorba         -> tyQCon  md nm [iface_ptr_ty_arg]
+	-- what's the IU/ID bit? Needed for processing AutoPrim.idl without
+	-- a hitch. ToDo: remove it.
+     | optHaskellToC && not (nm `elem` ["IUnknown", "IDispatch"]) -> tyQConst md nm
+     | optJNI && attrs `hasAttributeWithName` "jni_iface_ty" -> 
+     	        let i = tyVar "a" in
+		mkTyCon jObject
+			[ ctxtTyApp (ctxtClass (mkQualName md nm) [mkTyCon jObject [i]]) i ]
+     | optSubtypedInterfacePointers -> tyQCon  md nm [iface_ptr_ty_arg]
+     | otherwise		    -> tyQConst md nm
+   Pointer pt _ (Name _ _ _ _ _ (Just ti))
+     | pt /= Ptr && is_pointed ti ->
+        (\ x -> 
+	 if pt == Unique {-&& not (isVARIANTTy x)-} then 
+	    tyQCon prelude "Maybe" [x] 
+	 else x) $
+   	case mkTyConst (haskell_type ti) of
+	   t | optCom && isTyVar t -> 
+			if isGround then
+			   mkTyConst vARIANT
+			else
+			   ctxtTyApp (ctxtClass variantClass [t]) t
+	     | otherwise           -> t
+
+   Pointer pt _ t
+     | pt /= Ptr && isFunTy t -> toHaskellTy isGround t
+
+   Pointer Ptr _ (Name _ _ _ (Just as) _ _) 
+     | as `hasAttributeWithName` "foreign" -> tyForeignObj
+
+   Pointer _ _ t | isVoidTy t || (isConstructedTy t && isReferenceTy t) -> tyAddr
+   Pointer pt _ t
+      | pt == Ref || (optHaskellToC && isIfaceTy t) ->
+		if isIfaceTy t then
+		   toHaskellTy isGround (getIfaceTy t)
+		else
+		   toHaskellTy isGround t
+      | pt == Unique ->
+	     tyQCon prelude "Maybe" $
+	     case t of
+	       Void -> [tyAddr]
+               _  
+	       --  optDeepMarshall  -> [tyPtr (toHaskellTy isGround ty)]
+	        | optCom && isIfaceTy t -> [toHaskellTy isGround (getIfaceTy t)]
+		| otherwise	   -> [toHaskellTy isGround t]   -- is this right?
+
+      | isVariantTy t -> toHaskellTy isGround t
+      | otherwise -> -- assumed to be a pure/raw pointer
+             tyPtr (toHaskellTy isGround t)
+   Struct i _ _     -> tyConst' i
+   Union u _ _ _ _  -> tyConst' u
+   CUnion u  _ _    -> tyConst' u
+   UnionNon u _     -> tyConst' u
+   Enum   i _ _     -> tyConst' i
+   Iface{}          -> toHaskellIfaceTy ty
+   _		    -> error ("toHaskellTy: "++showCore (ppType ty))
+   where
+    iface_ptr_ty_arg = tyVar "a"
+
+    tyConst' i = tyQConst 
+		    (idHaskellModule i)
+		    (mkHaskellTyConName (idName i))
+
+\end{code}
+
+
+%*
+%
+<sect>Mapping <tt/structs/ to Haskell types</sect>
+<label id="sec:type:struct:translate">
+%
+%*
+
+We derive a Haskell type from a @struct@ as follows:
+
+ struct Tag { [a1]f_1 : t1; [a2]f_2:t2; [a_n]f_3:t_n; }
+
+ ===>  data _ = Tag { h_1 :: T1, ... h_m :: Tm }
+
+<itemize>
+<item> if f_i is not the size/length specifier of another
+field, it is added as a labelled field to the Haskell
+data type (converting the field name and type, first)
+
+<item>if f_i is a size/length specifier for another field, it
+is not directly represented in the generated type.
+Instead, the struct member that is the dependent of
+f_i is turned into a list. (We probably will need to
+add a flag that controls this rewrite.)
+
+<item>If @f_i@ is a switch id/tag for a non-encapsulated union, we
+leave the tag as a member of the struct, since it is useful on
+its own, and does in some cases contain more tag values than that
+used by the union (cf. the mysterious default union tag.)
+</itemize>
+
+\begin{code}
+mkHStructDef :: Id -> [Field] -> Haskell.ConDecl
+mkHStructDef tg fields =
+    recCon (mkHaskellTyConName (idName tg))
+           (map mkField fields')
+  where
+   mkField (i, t) = ( mkHaskellVarName (idName i), t)
+
+   dep_list  = findFieldDependents fields
+
+    -- any dependees apart from the switch_is() ones, which
+    -- we keep.
+   dependees = map    (idName.fieldId)  $
+	       filter (\ f -> isNotSwitchDependee dep_list (fieldId f) &&
+	       		      not (isVoidPointerTy (fieldType f)))
+		      fields
+
+   dependers = map (idName.fst) (filter (notNull.snd) dep_list)
+
+   fields' = 
+      map convDependees $
+       -- remove the size fields
+      filter (\ f -> notElem (idName (fieldId f)) dependees) fields
+
+   convDependees f
+       | (idName i) `elem` dependers = 
+		    let r_ty = removeNames ty in
+		    case r_ty of
+		      Array _ _        -> (i, toHaskellTy True ty)
+		      Pointer _ _ Void -> (i, toHaskellTy True r_ty)
+		      Pointer{}        -> (i, tyList (toHaskellTy True (removeNames (removePtr r_ty))))
+		      _		       -> (i, toHaskellTy True ty)
+       | otherwise = (i, toHaskellTy True ty)
+         where
+	  i  = fieldId f
+	  ty = fieldOrigType f
+
+mkHEnumDef :: Name -> [Attribute] -> EnumKind -> [EnumValue] -> [Haskell.ConDecl]
+mkHEnumDef enumTag attrs kind vals = addList (map mkCon vals)
+ where
+  addList =
+    case kind of 
+      EnumFlags{} -> (listCon:)
+      _ 
+        | optEnumsAsFlags || asFlag -> (listCon:)
+	| otherwise -> id
+
+  asFlag = attrs `hasAttributeWithName` "hs_flag"
+
+  listCon = conDecl (mkHaskellTyConName (enumTag ++ "List__"))
+      		    [tyList (tyCon (mkHaskellTyConName enumTag) [])]
+
+  mkCon ev = conDecl (mkHaskellTyConName (idName i))
+  		     tys
+   where
+     i   = enumName ev
+     tys = 
+     	(\ x -> 
+	  case x of 
+	   [] -> []
+	   xs -> [tyCon xs []]) $
+     	   unwords $
+	   map (\ xs -> '(':xs ++ ")") $
+	   map getStr $
+           filterAttributes (idAttributes i)
+     			    ["hs_tyarg"]
+     getStr (Attribute _ [ParamLit (StringLit s)]) = s
+     getStr _ = ""
+     
+mkHUnionDef :: Name -> [Switch] -> [Haskell.ConDecl]
+mkHUnionDef nm switches = concatMap mkCon switches
+  where
+   mkCon (SwitchEmpty Nothing)   = [conDecl (mkHaskellTyConName (nm ++ "_Anon")) []]
+   mkCon (SwitchEmpty (Just ls)) = 
+      map (\ x -> conDecl (mkHaskellTyConName (nm ++ x)) []) ls_nm
+       where
+        ls_nm = map snd ls
+   mkCon sw =
+      [conDecl (mkHaskellTyConName (idName (switchId sw)))
+               [toHaskellTy True (switchOrigType sw)]]
+
+mkCUnionDef :: [Field] -> [Haskell.ConDecl]
+mkCUnionDef fields = map mkCon fields
+  where
+   mkCon f = 
+      conDecl (mkHaskellTyConName (idName (fieldId f)))
+              [toHaskellTy True (fieldOrigType f)]
+
+\end{code}
+
+
+\begin{code}
+paramToHaskellType :: DependInfo -> Bool -> Bool -> Bool -> Param -> Haskell.Type
+paramToHaskellType deps isServer isAuto isResult p
+  | no_dependees && not keep_external = mkHaskellTy ty
+  | keep_external = mkHaskellTy ty'
+  | otherwise     = real_ty
+   where
+    nm		 = paramId p
+    attrs        = idAttributes nm
+
+      -- Note: we need to use the paramType rather than the
+      -- original type when peeling of a layer of pointers,
+      -- because the orig. type might be a straight synonym.
+      -- (the peeling function could look through names to avoid
+      -- this, but it doesn't at the moment.)
+    ty	
+      | peel	  = removePtrAndArray (paramType p)
+      | otherwise = paramOrigType p
+
+    dependees    = fromMaybe [] (lookupDepender deps nm)
+    no_dependees = null dependees
+
+    ty'  = mkPtrPointer ty
+    keep_external = 
+        attrs `hasAttributeWithName` "ptr"  ||
+	(not isResult && keepValueAsPointer ty)
+
+    mkHaskellTy t
+      | attrs `hasAttributeWithName` "foreign"  = tyForeignObj
+      | isAuto && paramMode p == In &&
+	attrs `hasAttributeWithName` "optional" = 
+	    if optOptionalAsMaybe then
+	       tyQCon prelude "Maybe" [autoTypeToHaskellTy pkind t]
+	    else
+	       overloadedTyVar variantClass "a"
+      | isAuto     = autoTypeToHaskellTy pkind t
+      | otherwise  = 
+	 (if isOut &&
+	     not (attrs `hasAttributeWithName` "iid_is")
+	   then groundTyVars else id) $ toHaskellTy isServer t
+
+    real_ty = go sizes ty
+
+    go (_:xs) acc 
+      | isVoidPointerTy (removeNames acc)    = tyAddr
+      | isPointerOrArrayTy (removeNames acc) = tyList (go xs (removePtrAndArray (removeNames acc)))
+    go _ acc     = 
+      (if isOut &&
+          not (attrs `hasAttributeWithName` "iid_is")
+        then groundTyVars else id) $ toHaskellTy isServer acc
+
+    (sizes, peel) = 
+     case computeArrayConstraints False{-not unmarshalling-} dependees of
+       (_,_,cs)   ->
+          case cs of
+	    (DepNone:cs1) | isOut  -> (cs1, True)
+--	    (_:cs) | isOut  -> (cs, True)
+	    _ -> (cs, False)
+
+    pkind = paramMode p
+
+    isOut = 
+      case pkind of
+        Out   -> True
+	_     -> False
+
+\end{code}
+
+
+Convert an IDL type into its corresponding Haskell <em/primitive/ representation.
+The primitive representation of a type is the representation expected externally.
+For example,
+
+    typedef [unique]char* pchar;
+
+is to the Haskell programmer represented as
+
+    type Pchar = Maybe Char
+
+the primitive representation of this unique pointer is an Addr (not such a big surprise),
+which is what we pass to an external function expecting a @pchar@ as argument.
+
+@toHaskellBaseTy@ implements the B scheme in the H/Direct paper.
+
+\begin{code}
+toHaskellBaseTy :: Bool -> Type -> Haskell.Type
+toHaskellBaseTy isResult ty =
+ case ty of
+   Integer sz s  -> mkIntTy sz s
+   Float sz      -> mkFloatTy sz
+   Char signed   -> mkCharTy signed
+   WChar         -> tyWChar
+   Bool          -> mkIntTy Long True
+   Void          -> tyUnit
+   Octet         -> tyWord8
+   Any           -> tyAddr
+   Object        -> tyAddr
+   String{}      -> tyPtr tyString
+   WString{}     -> tyPtr tyWString
+   FunTy{}       -> tyPtr (toHaskellTy False ty) -- (-- the toplevel type --)
+   StablePtr	 -> tyStable
+   Sequence{}    -> tyAddr --error "toHaskellBaseTy.Sequence: not implemented yet."
+   Fixed{}       -> error "toHaskellBaseTy.Fixed: not implemented yet."
+   Name _ _ _ _ _ (Just ti)
+     | not isResult && {- not (is_pointed ti) && -} finalised ti -> tyForeignObj
+
+   Name n _ _ _ mb_orig_ty mb_ti ->
+    case mb_ti of
+      Just ti ->  (if isResult then toPtrTy else id) $ prim_type ti
+      Nothing ->
+       case mb_orig_ty of
+         Nothing -> 
+	  trace ("toHaskellBaseTy: Warning, defaulting " ++ show n ++ "to Addr")
+	  tyAddr
+         Just t  -> toHaskellBaseTy isResult t
+
+   Pointer _ _ (Name _ _ _ _ _ (Just ti))
+     | not isResult && is_pointed ti && finalised ti ->
+	prim_type ti
+     | otherwise    -> (if not (is_pointed ti) && not (isPtrTy (prim_type ti)) 
+                        then tyPtr else id) $ ((if isResult then toPtrTy else id) $ prim_type ti)
+   Pointer _ _ i@(Iface nm _ _ attrs _ _) 
+        | not isResult ->
+	   if not optHaskellToC || 
+	      attrs `hasAttributeWithName` "finaliser" ||
+	      nm `elem` ["IUnknown" , "IDispatch"] -- fudge
+	        	    then
+	      tyForeignPtr (toHaskellIfaceTy i)
+	   else
+	      tyPtr (toHaskellIfaceTy i)
+	| otherwise    -> tyPtr (toHaskellIfaceTy i)
+
+   Pointer _ _ (Name n _ m _ _ _) ->
+      tyPtr (tyQConst (fmap mkHaskellTyConName m) (mkHaskellTyConName n))
+   Pointer _ _ t  -> tyPtr (toHaskellBaseTy isResult t)
+   Iface{}        -> toHaskellBaseTy isResult (Pointer Ref True ty)
+   Array t _      -> tyPtr (toHaskellBaseTy isResult t)
+   SafeArray _  
+     | isResult     -> tyPtr (mkTyConst sAFEARRAY)
+     | otherwise    -> tyForeignPtr (mkTyConst sAFEARRAY)
+   Struct i [f] _
+     | isSimpleTy (fieldType f) || 
+       ((idAttributes i) `hasAttributeWithName` "hs_newtype")
+     -> toHaskellBaseTy isResult (fieldType f)
+   Struct{}         -> tyAddr -- liar!
+   Union{}          -> tyAddr
+   CUnion{}         -> tyAddr
+   UnionNon{}       -> tyAddr
+   Enum{}           -> tyInt32
+   _		    -> error ("toHaskellBaseTy: not handled" ++ showCore (ppType ty))
+
+toBaseTy :: Type -> Type
+toBaseTy ty =
+ case ty of
+   Bool	        -> int32Ty
+   Octet        -> charTy
+   String{}     -> addrTy
+   WString{}    -> addrTy
+   Sequence{}   -> addrTy
+   FunTy{}      -> addrTy
+    -- ToDo: get rid of this.
+   Name "VARIANT_BOOL" _ _ _ _ _ | optCom -> ty
+   Name _ _ _ _ Nothing  _ -> addrTy -- your guess is as good as mine.
+   Name _ _ _ _ (Just t) _ -> toBaseTy t
+   Struct i [f] _
+     | isSimpleTy (fieldType f) ||
+       ((idAttributes i) `hasAttributeWithName` "hs_newtype")
+     -> toBaseTy (fieldType f)
+   Struct{}        -> addrTy
+   Enum{}          -> int32Ty
+   Union{}         -> int32Ty
+   UnionNon{}      -> int32Ty
+   CUnion{}	   -> int32Ty
+   Pointer _ _ t
+      | isIfaceTy t    -> ty
+      | otherwise      -> addrTy
+   Array{}	       -> addrTy
+   SafeArray{}	       -> addrTy
+   _		       -> ty
+   
+\end{code}
+
+Provide the 'direct' mapping of a method/function.
+
+\begin{code}
+toHaskellBaseMethodTy :: Bool -> [Param] -> Result -> Haskell.Type
+toHaskellBaseMethodTy isRes ps res 
+  = case generaliseTys (res_ty : p_tys) of
+      ((r:ps1), mb_c) -> mbCtxtTyApp mb_c (funTys ps1 r)
+  where
+    res_ty = io (toPtrTy (toHaskellBaseTy True (resultType res)))
+    p_tys  = map (toPtrTy.(toHaskellBaseTy isRes).paramType) ps
+
+\end{code}
+
+\begin{code}
+mkMarshaller :: String -> Type -> QualName
+mkMarshaller pre ty =
+ case ty of
+   Name _ _ _ _ (Just t@(Name{}))  _ -> mkMarshaller pre t
+   Name _ _ _ _ (Just t) _ | not (isConstructedTy t) -> mkMarshaller pre t
+   Name n _ md _ _ _ -> mkQVarName md (pre ++ mkHaskellTyConName n)
+   Struct i [] _     -> mkQVarName (idModule i) (pre ++ mkHaskellTyConName (idName i))
+--   _ -> appHTy pre (toHaskellBaseTy False ty)
+--   _ -> mkQVarName Nothing ("(" ++ pre ++ " " ++ (PPHaskell.showAbstractH (ppType ty)) ++ ")")
+   _ -> prefixHTy pre (toHaskellBaseTy False ty)
+
+\end{code}
+
+\begin{code}
+autoTypeToHaskellTy :: ParamDir -> Type -> Haskell.Type
+autoTypeToHaskellTy pkind ty =
+  case mbAutoTypeToHaskellTy pkind ty of
+    Just x  -> x
+    Nothing -> 
+     trace ("autoTypeToHaskellType: unknown auto type "++ showCore (ppType ty) ++ "\n Giving it a variant type") $
+     (overloadedTyVar variantClass "a")
+
+mbAutoTypeToHaskellTy :: ParamDir -> Type -> Maybe Haskell.Type
+mbAutoTypeToHaskellTy pkind ty = 
+ case ty of
+    -- Note: we disregard the '[unique]' flag on the string types here;
+    -- Automation doesn't support [unique].
+   String{}      -> Just $ mkTyConst $ mkQualName prelude stringName
+   WString{}     -> Just $ mkTyConst $ mkQualName prelude stringName
+   Integer sz isSigned ->
+     case sz of
+       Short
+	 | isSigned  -> Just $ mkTyConst $ tyInt16Name
+	 | otherwise -> Just $ mkTyConst $ tyWord16Name
+       Long 
+	 | isSigned  -> Just $ mkTyConst $ tyInt32Name
+	 | otherwise -> Just $ mkTyConst $ tyWord32Name
+       Natural
+	 | optIntIsInt && isSigned -> Just $ mkTyConst $ tyIntName
+	 | isSigned  -> Just $ mkTyConst $ tyInt32Name
+	 | otherwise -> Just $ mkTyConst $ tyWord32Name
+       LongLong
+	 | optLongLongIsInteger -> Just $ mkTyConst $ tyIntegerName
+	 | isSigned	        -> Just $ mkTyConst $ tyInt64Name
+	 | otherwise		-> Just $ mkTyConst $ tyWord64Name
+
+   Char{}        -> Just $ mkTyConst $ mkQualName prelude "Char" -- dodgy, but it works..
+   Octet	 -> Just $ mkTyConst $ mkQualName prelude "Char"
+   Bool		 -> Just $ mkTyConst $ mkQualName prelude "Bool"
+   Float sz      ->
+     case sz of
+       Short     -> Just $ mkTyConst $ mkQualName prelude "Float"
+       Long      -> Just $ mkTyConst $ mkQualName prelude "Double"
+       LongLong	 -> Just $ mkTyConst $ mkQualName prelude "Double"
+       Natural   -> Just $ mkTyConst $ mkQualName prelude "Float"
+
+   Pointer _ _ (Iface "IUnknown" _ _ _ _ _)  -> Just (mkIType iUnknown)
+   Pointer _ _ (Iface "IDispatch" _ _ _ _ _) -> Just (mkIType iDispatch)
+   Pointer _ _ (Iface nm md _ _ _ _)         -> Just $ mkIType $ mkQualName md (mkIfaceTypeName nm)
+   Pointer _ _ Void		 -> Just varTy
+   Pointer _ _ (Name _ _ _ _ _ (Just ti)) 
+      | is_pointed ti  -> Just (mkAutoTyConst (auto_type ti))
+   Iface "IUnknown" _ _ _ _ _	 -> Just $ mkIType iUnknown
+   Iface "IDispatch" _ _ _ _ _   -> Just $ mkIType iDispatch
+   Iface nm md _ _ _ _           -> Just $ mkIType $ mkQualName md (mkIfaceTypeName nm)
+
+   SafeArray t		   -> 
+	    case mbAutoTypeToHaskellTy Out{-want to ground any embedded iface-pointers-} t of
+	      Nothing -> Nothing
+--	      Just x  -> Just $ mkTyCon (mkQualName autoLib "SafeArray") [groundTyVars x]
+	      Just x  -> Just $ mkTyCon (mkQualName autoLib "SafeArray") [x]
+   (Name "HRESULT" _ _ _ _ _)  -> Just $ mkTyConst $ mkQualName comLib "HRESULT"
+   (Name "VARIANT_BOOL" _ _ _ _ _) -> Just $ mkTyConst $ mkQualName prelude "Bool"
+--   (Name "VARIANT" _ _ _ _ _)  -> Just varTy
+{- BEGIN_SUPPORT_TYPELIBS
+   (Name _ _ _ _ _ (Just ti)) | isJust (auto_vt ti) -> Just $ mkAutoTyConst (auto_type ti)
+   END_SUPPORT_TYPELIBS -}
+   (Name nm _ md _ (Just Enum{}) _) -> Just $ mkTyConst $ mkQualName md (mkHaskellTyConName nm)
+   (Name _ _ _ _ (Just orig_ty) _)   -> mbAutoTypeToHaskellTy pkind orig_ty
+   (Name _ _ _ _ _ (Just ti))      -> Just (mkTyConst $ haskell_type ti)
+   Name{}                          -> Nothing
+   Pointer _ _ t                   -> mbAutoTypeToHaskellTy pkind t
+   Enum{} 			   -> Just $ mkTyConst $ mkQualName prelude "Int"
+     --As if by magic..
+   (Struct (Id {idName="TagVARIANT"}) _ _) -> Just varTy
+   _ -> Nothing
+ where
+   -- leave these as a type variable, later pass will constrain
+   -- it with the approp. context.
+  varTy = overloadedTyVar variantClass "a"
+
+  isOut = pkind == Out
+
+  mkIType qv
+   | optSubtypedInterfacePointers && isOut = mkTyCon qv [mkTyConst groundInterface]
+   | optSubtypedInterfacePointers          = mkTyCon qv [tyVar "a"]
+   | otherwise                             = mkTyCon qv [tyVar "a"]	     
+
+
+{-
+ Type variables are Variant-overloaded.
+-}
+mkAutoTyConst :: QualName -> Haskell.Type
+mkAutoTyConst q =
+  case mkTyConst q of
+    t | isTyVar t -> ctxtTyApp (ctxtClass variantClass [t]) t
+      | otherwise -> t
+
+autoTypeToQName :: Type -> QualName
+autoTypeToQName ty =
+  case ty of
+   String{}    -> mkQualName prelude "String"
+   WString{}   -> mkQualName prelude "String"
+   Integer sz isSigned ->
+     case sz of
+       Short
+	 | isSigned  -> tyInt16Name
+	 | otherwise -> tyWord16Name
+       Long 
+	 | isSigned  -> tyInt32Name
+	 | otherwise -> tyWord32Name
+       Natural
+	 | optIntIsInt && isSigned -> tyIntName
+	 | isSigned  -> tyInt32Name
+	 | otherwise -> tyWord32Name
+       LongLong
+	 | optLongLongIsInteger -> tyIntegerName
+	 | isSigned	        -> tyInt64Name
+	 | otherwise		-> tyWord64Name
+
+   Char{}        -> mkQualName prelude "Char" -- dodgy, but it works.. (don't take signedness into account, nor the size of a Haskell Char)
+   Octet         -> mkQualName prelude "Char"
+   Bool		 -> mkQualName prelude "Bool"
+   Float sz      ->
+     case sz of
+       Short     -> mkQualName prelude "Float"
+       Long      -> mkQualName prelude "Double"
+       LongLong  -> mkQualName prelude "Double"
+       Natural   -> mkQualName prelude "Float"
+
+   Iface _ _ _ _ is_idis _
+        | is_idis   -> iDispatch
+	| otherwise -> iUnknown
+   Pointer _ _ Void -> mkQualName autoLib "Variant" 
+   SafeArray{}		    -> mkQualName autoLib "SafeArray"
+   (Name "HRESULT" _ _ _ _ _) -> mkQualName comLib "HRESULT"
+    -- hack
+--   (Name "LPSTR" _ _ _ _ _) -> mkQualName prelude stringName
+   Name _ _ _ _ _ (Just ti)
+   	| isTyVar (mkTyConst (auto_type ti)) -> mkQualName autoLib "Variant"
+	| otherwise			     -> auto_type ti
+   Name _ _ _ _ (Just orig_ty) _ -> autoTypeToQName orig_ty
+   Name nm _ _ _ _ _            -> 
+	trace ("warning: found type name " ++ show nm ++ " but not its defn.") $
+	mkQualName autoLib "Variant"
+   Pointer _ _ (Name _ _ _ _ _ (Just ti))
+        | is_pointed ti ->
+	   let at = auto_type ti in
+	   if isTyVar (mkTyConst at) then
+	      mkQualName autoLib "Variant"
+	   else
+	      at
+   Pointer _ _ t               -> autoTypeToQName t
+   Enum{}                      -> mkQualName autoLib "Enum"
+   (Struct (Id {idName="TagVARIANT"}) _ _) -> mkQualName autoLib "Variant"  -- hmm..
+   _ -> trace ("autoTypeToQName: unknown auto type "++ showCore (ppType ty) ++ "\n Giving it a variant type") $
+	mkQualName autoLib "Variant"
+
+\end{code}
+ src/MarshallDep.lhs view
@@ -0,0 +1,617 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 9th 2003  15:04  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Handling the marshalling of dependent arguments/fields.
+
+\begin{code}
+module MarshallDep 
+	( marshallDependents
+	, unmarshallDependents
+	, freeDependent
+	
+	) where
+
+import qualified AbstractH as Haskell (Expr)
+import AbsHUtils
+import CoreIDL
+import CoreUtils
+
+import MarshallMonad
+import MarshallUtils
+import MarshallType
+import MarshallCore
+
+import BasicTypes
+import LibUtils
+
+import List  ( nubBy )
+import Maybe ( mapMaybe, fromMaybe, fromJust, isJust )
+import Monad ( when )
+
+\end{code}
+
+%*
+%
+\section[marshall-dep]{Marshalling dependent parameters}
+%
+%*
+
+
+\begin{code}
+marshallDependents :: Bool
+		   -> Bool
+                   -> DependInfo
+		   -> (Name -> Type)
+		   -> Mm ()
+marshallDependents inStruct forServer ls lookup_ty = do
+  sequence (map marshallDep ls)
+  return ()
+ where
+  {-
+   Marshall the field members/parameters. A field/param
+   is either a depender or a dependee (never both.)
+  -}
+  marshallDep (_, [])   = return () -- no dependencies - no code to generate here.
+  marshallDep (i, deps) = marshallDependent inStruct forServer i lookup_ty deps
+\end{code}
+
+This function assumes that the dependencies are correct, that is,
+well formed, no duplicates nor conflicting attributes were used
+when the dependency information was computed.
+
+   foo([in]int *len, [in,size_is(*len)]char* ls);
+
+It performs the following tasks:
+
+ - creates let bindings for the dependees, i.e.,
+
+      let len = length ls
+
+ - marshalls the dependers, i.e.,
+
+      ls <- m_list s_Char len w_Char ls
+
+ - in preparation for calling the external function,
+   allocate the dependees, i.e.,
+
+      len <- m_ref (allocOutPointer sizeofInt32) w_Int32 len
+
+\begin{code}
+marshallDependent :: Bool
+		  -> Bool
+		  -> Id
+		  -> (Name -> Type)
+		  -> [Dependent]
+		  -> Mm ()
+marshallDependent _ _ _ _ [Dep SwitchIs [DepVal{}]] = return ()
+marshallDependent inStruct forServer i lookup_ty deps' = do
+ addCode (hLets dep_binds)
+ (if inStruct && isArrayTy (removeNames ty) then
+     return ()
+  else 
+     addCode (bind (funApply marshall_list [real_nm]) real_nm))
+ when (not forServer) (dep_ptrs  >> return ())
+ return ()
+  where
+   nm	         = idName i
+   ty	         = lookup_ty nm
+   marshall_list = marshallList inStruct
+   				True
+                                ty lookup_ty
+				   (varName m_list)
+   				   trans_start_posns 
+			   	   trans_end_posns 
+				   alloc_sizes
+   (trans_start_posns, trans_end_posns, alloc_sizes) 
+                 = computeArrayConstraints False{-marshalling-} deps
+
+   -- size information may be in part be specified as part of
+   -- the (array) type, i.e.,  [size_is(len,)] char arr[][20];
+   -- 
+   -- we push this info into the dependency list here. It really
+   -- should be done as part of desugaring. (ToDo.)
+   deps         = 
+    case ty of
+      Array _ es -> 
+         case es of
+	  []      -> deps'
+	  [e]     ->
+            case break (isSizeIs) deps' of
+	     (_,[]) -> ((Dep SizeIs [exprToDep e]):deps')
+	     (as,(Dep SizeIs ds):bs) -> as++(Dep SizeIs (combine ds (exprToDep e))):bs
+             _      -> error "MarshallDep.marshallDependent: expected a SizeIs attribute"		
+          [e1,e2] -> [ Dep FirstIs [exprToDep e1]
+	  	     , Dep LastIs  [exprToDep e2]
+		     ] ++ deps'
+          _      -> error "MarshallDep.marshallDependent: expected at most two attributes"
+          where
+
+	   combine (DepNone:ds) d = d:ds
+	   combine d       _ = d
+
+	   exprToDep e = 
+	     case (findFreeVars e) of
+	       []    -> DepVal Nothing e
+	       (v:_) -> DepVal (Just v) e
+
+      _ -> deps'
+
+   size_deps = filter (\d -> sizeOrLength d && 
+			     hasNonConstantExprs d) deps
+
+   dep_binds   = nubBy (\ a b -> isVarsEq (fst a) (fst b)) $
+		 concat       $ 
+		 map toBinder size_deps
+   dep_ptrs    = sequence       (
+                 map allocPtr   $
+		 nubBy (\ (DepVal (Just a) _)
+		 	  (DepVal (Just b) _) -> a == b) $
+		 filter isDeref $
+   		 concat         $
+		 map (\ (Dep _ ls) -> ls) size_deps)
+
+   real_nm     = mkHVar i
+
+   -- partial solution
+   allocPtr (DepVal (Just v) (Unary Deref e)) =
+	addCode (bind (funApply (marshallType stubMarshallInfo (lookup_ty v))
+				[coreToHaskellExpr e]) (var v))
+   allocPtr _ = error "MarshallDep.marshallDependent.allocPtr: unexpected value"
+
+   isDeref (DepVal (Just _) (Unary Deref _)) = True
+   isDeref _ = False
+
+   -- convert a dependency list       
+   toBinder (Dep _ ls) = mapMaybe toBinds ls
+     where
+      toBinds (DepVal (Just v) e@(Var _)) =
+        Just ( var v, subst v len (coreToHaskellExpr e))
+	where
+	 len = mkLength (lookup_ty v)
+         
+      toBinds (DepVal (Just v) e) = 
+         Just (var v, subst v' len (coreToHaskellExpr (solve v (Var v') e)))
+         where
+	  v'  = v ++ "'"
+          len = mkLength (lookup_ty v)
+         
+      toBinds _ = Nothing
+
+   mkLength to_ty = 
+      -- if the external function expects a [unique] pointer to the
+      -- value holding the length, wrap a Just around the length of the list.
+     case to_ty of
+        Pointer Unique _ _ -> just length_expr
+	_		   -> length_expr
+    where
+      length_expr = 
+	  coerceTy intTy (removePtrs to_ty) $
+          case removeNames ty of 
+	      -- if the depender is a wide string, use appropriate
+	      -- length function.
+	      -- ToDo: add a "Type -> QualName" function which
+	      --  returns the name of the length computing function
+	      --  to use for the given Core type.
+	    WString{} -> funApp lengthWString [var nm]
+	    _         -> funApp lengthName    [var nm]
+
+
+
+\end{code}
+
+\begin{code}
+unmarshallDependents :: Bool  -- working inside a struct/union?
+		     -> Bool  -- dealing with [out] parameters?
+	             -> DependInfo
+		     -> (Name -> Type)
+		     -> Mm ()
+unmarshallDependents inStruct is_out ls lookup_ty = do
+ marshall_dependees
+ sequence (map unmarshallDep ls)
+ return ()
+  where
+   deps = concat (map snd ls)
+
+    {-
+     Marshal the field members/parameters. A field/param
+     is either a depender or a dependee (never both.)
+    -}
+   unmarshallDep (_, [])    = return ()   -- no dependencies on this one, just continue.
+   unmarshallDep (i, deps1) =
+       case (findPtrType True (idAttributes i)) Void of
+         Pointer Ptr _ _ -> return ()
+	 _               -> unmarshallDependent inStruct is_out i lookup_ty deps1
+			       -- split off into separate function for clarity.
+
+   marshall_dependees = sequence (map toBinds code)
+
+   code = nubBy theSame  $
+	  concatMap (\ (Dep _ ds) -> filter nonConstantDep ds) $
+	  filter (\d -> sizeOrLength d && 
+	  		hasNonConstantExprs d &&
+			not (isResult d)) deps
+
+    -- HACK, need to take into account scoping, so that we don't
+    -- run the risk of not unmarshalling dependent arguments named
+    -- "result"!
+   isResult (Dep _ xs) = any isRes xs
+     where
+      isRes (DepVal (Just "result") _) = True
+      isRes _			       = False
+
+   -- the actions we're creating here are only responsible for fishing
+   -- out values from pointers, so we only need to do this once.
+   theSame (DepVal (Just a) _) (DepVal (Just b) _) = a == b
+   theSame _ _ = False 
+
+   nonConstantDep (DepVal (Just _) _) = True
+   nonConstantDep _		      = False
+
+   toBinds (DepVal (Just v) (Var _))
+       = let v'   = v
+	     ty   = lookup_ty v'
+         in
+         addCode (bind (funApply (unmarshallType stubMarshallInfo ty) [var v']) (var v'))
+   toBinds (DepVal (Just v) e) = 
+         let 
+             v'    = v ++ "'"
+	     ty    = lookup_ty v
+	 {-
+	   For a case like the following: 
+		    void foo([out]int *len,[out,size_is(*len+2)]char* ps[]);
+
+	   we want to generate unmarshalling code for ps that gets at the
+           value of len:
+ 
+            len <- ((u_ref r_Int32) len)
+            let len' = (len + 2)
+            ps <- u_list s_Addr 0 (fromIntegral len') ....
+ 
+	  the code below generates the first two lines, binding the value
+	  read out of 
+	  
+	 -}    
+	
+         in do
+         addCode (bind (funApply (unmarshallType stubMarshallInfo ty) [var v]) (var v))
+	 addToEnv v v'
+	 addCode (hLet (var v') (subst v (var v) (coreToHaskellExpr e)))
+
+   toBinds _ = error "MarshallDep.unmarshallDependents.toBinds: unexpected value"
+
+{-
+ This function assumes that the dependencies are correct, that is,
+ well formed, no duplicate nor conflicting attributes were used
+ when the dependency information was computed.
+-}
+unmarshallDependent :: Bool
+		    -> Bool
+		    -> Id 
+		    -> (Name -> Type) 
+		    -> [Dependent] 
+		    -> Mm ()
+unmarshallDependent _ _ _ _ [Dep SwitchIs _] = return ()
+unmarshallDependent inStruct is_out i lookup_ty deps' = do
+ unmarsh <- unmarshallList inStruct
+ 			   True{-at top-level-}
+                           ty 
+ 			   lookup_ty
+                           (trans_start_posns)
+			   (trans_end_posns)
+			   (alloc_sizes)
+ let 
+      -- in the case of [out] parameters, de-reference the 
+      -- the pointer to get at the goods. This is only done
+      -- when the [out] parameter was (at least) a pointer to
+      -- a pointer to something. If not, then the [out] pointer 
+      -- points to the piece of a memory (we've already allocated)
+      -- and are now ready to unmarshal.
+     unmarsh' 
+       | is_out && allocated_space_for = funApp r_ref [unmarsh]
+       | otherwise = unmarsh
+
+     unmarsh_and_free
+       | is_out   =
+	funApp doThenFree 
+	       [ fromMaybe (varName trivialFree) (freeDependentE i lookup_ty deps')
+	       , unmarsh'
+	       ]
+       | otherwise = unmarsh'
+
+ addCode (bind (funApply unmarsh_and_free [nm_var]) nm_var)
+  where
+   nm	         = idName i
+   tentative_ty  = lookup_ty nm
+   ty        
+     | should_peel = removePtr tentative_ty
+     | otherwise   = tentative_ty
+
+   nm_var        = mkHVar i
+
+   {-
+     Determine whether we had to allocate space for an [out] pointer.
+     If we did, we need to deref this pointer before unmarshalling -- see above.
+   -}
+   allocated_space_for =
+        is_out && 
+	let
+	 (_, _, cs1) = computeArrayConstraints False{-marshalling-} deps'
+	in
+	case cs1 of
+	  (DepNone:_) -> True
+	  _           -> False
+
+   should_peel 
+    | not is_out = False
+    | otherwise  =
+        case cs of
+	  (DepNone:_) -> True
+	  _	      -> False
+
+{-
+   -- size information may be in part be specified as part of
+   -- the (array) type, i.e.,  [size_is(len,)] char arr[][20];
+   -- 
+   -- we push this info into the dependency list here. It really
+   -- should be done as part of desugaring. (ToDo.)
+   deps         = 
+    case ty of
+      Array _ es -> 
+         case es of
+	  []      -> deps'
+	  [e]     ->
+            case break (isSizeIs) deps' of
+	     (as,[]) -> ((Dep SizeIs [exprToDep e]):deps')
+	     (as,(Dep SizeIs ds):bs) -> as++(Dep SizeIs (combine ds (exprToDep e))):bs
+          [e1,e2] -> [ Dep FirstIs [exprToDep e1]
+	  	     , Dep LastIs  [exprToDep e2]
+		     ] ++ deps'
+          where
+
+	   combine (DepNone:ds) d = d:ds
+	   combine d       _ = d
+
+	   exprToDep e = 
+	     case (findFreeVars e) of
+	       []    -> DepVal Nothing e
+	       (v:_) -> DepVal (Just v) e
+
+      _ -> deps'
+-}
+
+   (as, bs, cs) = computeArrayConstraints True{-unmarshalling-} deps'
+
+   (trans_start_posns, trans_end_posns, alloc_sizes)
+     | should_peel = (tail as, tail bs, tail cs) -- peel off the toplevel pointer for [out] params
+     | otherwise   = (as, bs, cs)
+
+\end{code}
+
+\begin{code}
+marshallList :: Bool
+	     -> Bool
+             -> Type
+	     -> (Name -> Type)
+	     -> Haskell.Expr
+	     -> [DepVal]{-start index of transmits, one for each dim.-} 
+	     -> [DepVal]{-end index of transmits-}
+	     -> [DepVal]{-size to allocate (for each dimension)-}
+	     -> Haskell.Expr
+marshallList inStruct topLev ty _ _ [] [] [] = marshallElts inStruct topLev True ty
+marshallList inStruct topLev ty lookup_ty marshaller
+	     (_:starts) (_:ends) (_:sz_allocs)
+ | (isPointerTy r_ty && not (isVoidPointerTy r_ty)) || isArrayTy r_ty  =
+   funApply marshaller
+            [ szType ty'
+            , marshallList inStruct False ty' lookup_ty ref_marshaller starts ends sz_allocs
+	    ]
+ | otherwise	= marshallElts inStruct topLev True ty
+  where
+   r_ty = removeNames ty
+   ref_marshaller = funApp w_list [varName alloc_list]
+   
+   alloc_list 
+      | isStringTy ty'  || 
+        isPointerTy ty' || 
+	isArrayTy ty'	    = true
+      | otherwise	    = false
+
+   ty'    = removePtrAndArray r_ty
+
+marshallList _ _ _ _ _ _ _ _ = error "MarshallDep.marshallList: the impossible happened"
+
+unmarshallList :: Bool
+	       -> Bool
+               -> Type
+	       -> (Name -> Type)
+	       -> [DepVal]{-start index of transmits, one for each dim.-} 
+	       -> [DepVal]{-end index of transmits-}
+	       -> [DepVal]{-size to allocate (for each dimension)-}
+	       -> Mm Haskell.Expr
+unmarshallList inStruct topLev ty _ [] [] []  = return (marshallElts inStruct topLev False ty)
+unmarshallList inStruct topLev ty l_ty
+               (_:starts) (_:ends) (sz:sz_allocs)
+ | (isPointerTy r_ty && not (isVoidPointerTy r_ty)) ||
+   isArrayTy r_ty  = do
+     rest <- unmarshallList inStruct False ty' l_ty starts ends sz_allocs
+     len  <- mkLengthExpr sz l_ty
+     return (funApp u_list [ szType ty'
+			   , var "0"
+			   , len
+			   , rest
+			   ])
+
+ | otherwise	= return (marshallElts inStruct topLev False ty)
+ where
+   r_ty   = removeNames ty
+
+   ty'    = removePtrAndArray r_ty
+unmarshallList _ _ _ _ _ _ _ = error "MarshallDep.unmarshallList: the impossible happened"
+
+mkLengthExpr :: DepVal -> (Name -> Type) -> Mm Haskell.Expr
+mkLengthExpr sz lookup_ty = 
+ case sz of
+   DepNone           -> return nothing
+   DepVal Nothing e  -> return (coerceTy intTy word32Ty (coreToHaskellExpr e))
+   DepVal (Just v) e -> do
+	 mb_nm <- lookupName v
+	 mNm   <- getMethodName
+	 let 
+	   nm  = 
+	     case mb_nm of
+	       Nothing 
+	         | v == "result" && isJust mNm -> 
+		 	outPrefix ++ fromJust mNm
+	         | otherwise ->
+		        error ("MarshallDep.mkLengthExpr: unbound variable ('" ++
+			       nm ++ "') encountered in length_is() attribute")
+	       Just x -> x
+
+	   ty  = lookup_ty v
+	   h_e = subst v (var nm) (coreToHaskellExpr e)
+
+
+	   coerce = coerceTy (removePtrs ty) word32Ty
+				      
+           {-
+	    In the case the length is given via a [unique] pointer,
+	    we will have at this stage unmarshalled it to a Maybe value.
+	    Convert the Maybe value into a length here.
+	   -}
+	 case ty of
+	   Pointer Unique _ _ -> return (
+				funApp fromMaybeName
+				       [ var "0"
+				       , funApp mapName [lam [patVar "x"] 
+				       			     (coerce (var "x")), h_e]
+				       ])
+	   Pointer Ptr _ _  -> error "mkLengthExpr: Ptr - no can do."
+	   _		    -> return (coerce h_e)
+
+marshallElts :: Bool -> Bool -> Bool -> Type -> Haskell.Expr
+marshallElts inStruct topLev marshalling ty
+   | marshalling && topLev = marshallType      mInfo ty
+   | marshalling           = refMarshallType   mInfo ty
+   | topLev                = unmarshallType    mInfo ty
+   | otherwise		   = refUnmarshallType mInfo ty
+ where
+  mInfo = stubMarshallInfo{forStruct=inStruct,forRef=True}
+\end{code}
+
+When freeing up values that have been classified and marshalled as
+dependent [in] params, we need to make sure we free the entire structure
+that has been previously allocated. @freeDependent@ takes care of this,
+by, in effect, by reconstructing what kind of pointer / array value that
+the 'dependent arg' marshaller previously constructed.
+
+\begin{code}
+freeDependent :: Id -> (Name -> Type) -> [Dependent] -> Mm ()
+freeDependent i lookup_ty deps = 
+   case freeDependentE i lookup_ty deps of
+     Nothing -> return ()
+     Just f  -> addCode (bind_ (funApply f [real_nm]))
+ where
+  real_nm   = mkHVar i
+
+freeDependentE :: Id -> (Name -> Type) -> [Dependent] -> Maybe Haskell.Expr
+freeDependentE i lookup_ty deps = free_list
+ where
+  free_list = freeList ty lookup_ty trans_start_posns trans_end_posns alloc_sizes
+  (trans_start_posns, trans_end_posns, alloc_sizes)
+            = computeArrayConstraints False{-not unmarshaling-} deps
+
+  ty = lookup_ty (idName i)
+
+
+freeList :: Type
+	 -> (Name -> Type)
+	 -> [DepVal]{-start index of transmits, one for each dim.-} 
+	 -> [DepVal]{-end index of transmits-}
+	 -> [DepVal]{-size to allocate (for each dimension)-}
+	 -> Maybe Haskell.Expr
+freeList ty _  []    []    []    = freeElts (removePtrAndArray ty)
+freeList ty _  (_:_) (_:_) (_:_)
+ | (isPointerTy ty || isArrayTy ty) && needsFreeing ty' =
+   Just $ (varName free)
+{-
+   funApp f_list
+          [ szType ty'
+	  , length_of sz
+          , fromMaybe (varName trivialFree) (freeList ty' lookup_ty starts ends sz_allocs)
+	  ]
+-}
+ | otherwise = freeElts ty
+  where
+   ty'       = removePtrAndArray ty
+
+{-
+   length_of (DepVal Nothing  e) = coreToHaskellExpr e
+   length_of (DepVal (Just v) e) =
+	coerceTy (removePtrs (lookup_ty v)) word32Ty (coreToHaskellExpr e)
+-}
+
+freeList _ _ _ _ _ = error "MarshallDep.freeList: the impossible happened"
+
+freeElts :: Type -> Maybe Haskell.Expr
+freeElts ty =
+  case ty of
+   Sequence{}  -> Just $ varName free 
+      --Just $ funApp f_list [ szType t, freeElts' t ] -- wrong.
+   Fixed{}          -> error "not implemented yet."
+   SafeArray t      -> Just $ funApp f_list [ szType t, freeElts' t]
+   Array Void (d:_) -> Just $ funApp f_list [ szType (Pointer Ptr True Void)
+					    , coreToHaskellExpr d
+					    , mkEltFreer (Pointer Ptr True Void)
+					    ]
+   Array t (d:_) -> Just $ funApp f_list   [ szType t, coreToHaskellExpr d, freeElts' t]
+   String{}	 -> Just $ varName f_string
+   WString{}	 -> Just $ varName f_wstring
+   Pointer _ _ Iface{}    -> Nothing
+   Pointer _ _ Void       -> Just $ varName free
+   Pointer Ref _ (Char _) -> Just $ varName f_string
+   Pointer pt _ pty
+      | pt == Ref    -> Just $ funApp f_ref    [ freeElts' pty ]
+      | pt == Unique -> Just $ funApp f_unique [ freeElts' pty ]
+      | otherwise    -> Just $ varName f_ptr 
+   _	| needsFreeing ty -> Just (mkEltFreer ty)
+        | otherwise	  -> Nothing
+  where
+   freeElts' t   = fromMaybe (varName trivialFree) (freeElts t)
+
+   mkEltFreer ety = varName (mkMarshaller freePrefix ety)
+
+\end{code}
+
+
+
+Constants referring to library marshallers:
+
+\begin{code}
+m_list, w_list, u_list, f_list :: QualName
+m_list   = prefix marshallPrefix   (mkQVarName hdirectLib list)
+w_list   = prefix marshallRefPrefix   (mkQVarName hdirectLib list)
+u_list   = prefix unmarshallPrefix (mkQVarName hdirectLib list)
+f_list   = prefix freePrefix (mkQVarName hdirectLib list)
+
+{-
+r_list :: QualName
+r_list   = prefix unmarshallRefPrefix (mkQVarName hdirectLib list)
+-}
+
+f_string :: QualName
+f_string = prefix freePrefix (mkQVarName hdirectLib stringName)
+
+f_unique, r_ref, f_ref, f_wstring :: QualName
+f_unique = prefix freePrefix   (mkQVarName hdirectLib unique)
+r_ref    = prefix unmarshallRefPrefix (mkQVarName hdirectLib ref)
+f_ref    = prefix freePrefix   (mkQVarName hdirectLib ref)
+f_wstring = prefix freePrefix   (mkQVarName comLib wstring)
+
+f_ptr :: QualName
+f_ptr  = free
+\end{code}
+
+ src/MarshallEnum.lhs view
@@ -0,0 +1,310 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Jan. 30th 2003  14:19  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Generating code for going between IDL enums and
+their Haskell equivalent.
+
+\begin{code}
+module MarshallEnum 
+	   ( marshallEnum
+	   , genDerivedEnumInstanceFor
+	   ) where
+
+import MarshallType
+
+import BasicTypes ( BinaryOp(..),QualName, qName, EnumKind(..)  )
+import Literal    ( iLit  )
+import AbstractH  ( HDecl )
+import qualified AbstractH as Haskell ( CaseAlt, Expr )
+import CgMonad
+
+import AbsHUtils
+import LibUtils hiding ( enumToInt )
+import qualified LibUtils ( enumToInt )
+
+import CoreIDL
+import CoreUtils  ( mkHaskellTyConName )
+import Attribute  ( hasAttributeWithName, filterAttributes )
+import Literal    ( Literal(..) )
+import Opts ( optSmartEnums, optNoVariantInstance, 
+	      optVariantInstance, optEnumsAsFlags,
+	      optGenBitsInstance, optGenNumInstance
+	    )
+import PpCore ( ppEnumValue, showCore )
+
+\end{code}
+
+
+\begin{code}
+marshallEnum :: Id -> EnumKind -> Bool -> [EnumValue] -> CgM HDecl
+marshallEnum tdef_id kind noEnumInstance enums
+ | noEnumInstance && genVariantInstance = return variantInst
+ | noEnumInstance     = return emptyDecl
+ | genVariantInstance = return (enumInst `andDecl` variantInst)
+ | otherwise	      = return enumInst
+ where   
+  genVariantInstance = optVariantInstance && not optNoVariantInstance
+
+  attrs        = idAttributes tdef_id
+  tdef_name    = idName tdef_id
+  name         = mkVarName tdef_name
+
+  v            = var "v"
+  x1           = var "x1"
+  x2           = var "x2"
+  t_ty         = tyConst (qName name)
+
+    -- The size of the integer value an enum tags gets mapped
+    -- to is determined as follows:
+    -- 
+    --   - OMG IDL => Int32
+    --   - MIDL with v1_enum attr => Int32
+    --   - MIDL    => Int16
+    -- 
+    -- However, [v1_enum] (or not) only affects what's transmitted
+    -- across the network, so we can uniformly represent a marshalled
+    -- enum via an Int32.
+
+  enumInst = 
+    addBitsInstance $     
+    hInstance Nothing enumClass t_ty 
+	[ methodDef fromEnumName [varPat v] m_rhs 
+	, methodDef toEnumName   [varPat v] u_rhs 
+	]
+
+  variantInst = 
+    hInstance Nothing variantClass t_ty 
+	[ methodDef inVariantName      [] inv_rhs 
+	, methodDef resVariantName     [] resv_rhs 
+	, methodDef defaultVariantName [] def_rhs 
+	, methodDef vtEltTypeName      [] vt_elt_rhs
+	]
+
+  addBitsInstance d 
+   | withListCon = 
+   	if optGenBitsInstance || optGenNumInstance then
+	   (if optGenNumInstance then
+	       numInstance
+	    else
+	       numInstance `andDecl` bitsInstance) 
+          `andDecl` d
+	else
+	   flagsInstance `andDecl` d
+   | otherwise   = d
+
+  withListCon = 
+    case kind of
+      EnumFlags{} -> True
+      _           -> forceFlag
+
+  forceFlag = optEnumsAsFlags || attrs `hasAttributeWithName` "hs_flag"
+
+  numInstance  =
+    hInstance Nothing numClass t_ty
+        [ methodDef (mkQVarName prelude "+") [varPat x1, varPat x2] or_rhs
+	]
+
+  bitsInstance =
+    hInstance Nothing bitsClass t_ty
+	[ methodDef andName [varPat x1, varPat x2] and_rhs 
+	, methodDef orName  [varPat x1, varPat x2] or_rhs 
+	, methodDef xorName   []     xor_rhs
+	, methodDef complementName[] comp_rhs
+	, methodDef shiftName []     shift_rhs
+	, methodDef rotateName []    rot_rhs
+	, methodDef bitSizeName []   bit_rhs
+	, methodDef isSignedName []  isS_rhs
+	]
+
+  flagsInstance =
+    hInstance Nothing flagsClass t_ty
+	[ methodDef orFlagName  [varPat x1, varPat x2] or_rhs 
+	]
+
+  inv_rhs    = qvar autoLib "inEnum"
+  resv_rhs   = qvar autoLib "resEnum"
+  def_rhs    = qvar autoLib "defaultEnum"
+  vt_elt_rhs = qvar autoLib "vtTypeEnum"
+  
+  or_rhs    = funApp toEnumName [ binOp Add (funApp fromEnumName [x1])
+  					     (funApp fromEnumName [x2])]
+
+  and_rhs     = 
+    hLet (var "flatten")
+         (lam [patVar "x"] 
+    	      (hCase (var "x")
+	       	     [ alt (conPat (mkConName (tdef_name ++ "List__")) [patVar "xs"])
+		     	   (funApp concatMapName [var "flatten", var "xs"])
+		     , defaultAlt (Just (mkVarName "x")) (hList [var "x"])
+		     ]))
+         (dataCon (mkConName (tdef_name ++ "List__"))
+	          [funApp intersectName [ funApp (mkVarName "flatten") [x1]
+		  			, funApp (mkVarName "flatten") [x2]
+					]])
+
+  xor_rhs = funApp prelError
+  		   [ stringLit ("Bits.xor{"++qName name++"}: unimplemented") ]
+  comp_rhs = funApp prelError
+  		   [ stringLit ("Bits.complement{"++qName name++"}: unimplemented") ]
+  shift_rhs = funApp prelError
+  		   [ stringLit ("Bits.shift{"++qName name++"}: unimplemented") ]
+  rot_rhs = funApp prelError
+  		   [ stringLit ("Bits.rotate{"++qName name++"}: unimplemented") ]
+  bit_rhs = funApp prelError
+  		   [ stringLit ("Bits.bitSize{"++qName name++"}: unimplemented") ]
+  isS_rhs = funApp prelError
+  		   [ stringLit ("Bits.isSigned{"++qName name++"}: unimplemented") ]
+
+    -- Marshalling --
+  m_rhs
+    | not optSmartEnums || kind == Unclassified = hCase v (add_m_list (map (enumToInt True) enums))
+    | otherwise = 
+        case kind of
+	  EnumProgression st 1 -> binOp Add (intLit st)
+	  				    (funApp LibUtils.enumToInt [v])
+	  EnumProgression st step -> binOp Add (intLit st)
+	  				       (binOp Mul (intLit step)
+					       		  (funApp LibUtils.enumToInt [v]))
+	  EnumFlags 0 -> funApp enumToFlag [v]
+	  EnumFlags k -> funApp toIntFlag [intLit k, funApp LibUtils.enumToInt [v]]
+	  Unclassified -> error "MarshallEnum.marshallEnum.m_rhs: the impossible happened"
+
+  add_m_list 
+    | withListCon = ((alt (conPat (mkConName (tdef_name ++ "List__")) [patVar "xs"]) rhs) :)
+    | otherwise   = id
+   where
+    rhs = funApp orListName [funApp mapListName [varName fromEnumName, var "xs"]]
+
+  u_name   = qName (prefix unmarshallPrefix name)
+  u_rhs  
+    | not optSmartEnums || kind == Unclassified = normal_u_rhs
+    | otherwise            =
+        case kind of
+		-- solve y = step * x + st
+	  EnumProgression st 1 -> 
+	       funApp tagToEnum
+	       	   [funApp unboxInt
+		   	   [binOp Sub v (intLit st)]]
+	  EnumProgression st step -> 
+	       funApp tagToEnum
+	       	   [funApp unboxInt
+		   	   [binOp Div (binOp Sub v (intLit st))
+		   	     	      (intLit step)]]
+	  EnumFlags k ->
+		funApp tagToEnum
+		   [funApp unboxInt
+		   	   [funApp toIntFlag [intLit k, funApp flagToIntTag [v]]]]
+	  Unclassified -> error "MarshallEnum.marshallEnum.u_rhs: the impossible happened"
+	  	
+  normal_u_rhs = hCase v (add_u_list (map intToEnum enums) ++ 
+                         [defaultAlt Nothing
+			   (giveUp (u_name ++ ": illegal enum value "))])
+
+  giveUp msg =funApp prelError [stringLit msg]
+
+  add_u_list ls =
+    case kind of
+      EnumFlags start -> (ls ++ [alt (patVar "x") (rhsFlg start)])
+      _ | forceFlag   -> (ls ++ [alt (patVar "x") (rhsGen)])
+        | otherwise   -> ls
+   where
+    rhsFlg st= 
+          dataCon (mkConName (tdef_name ++ "List__"))
+    		  [ funApp mapMaybeName
+		  	   [ lam [patVar "val"]
+			   	 (hIf (binOp Eq (binOp And (var "val") (funApp fromIntegralName [var "x"]))
+					       (var "val"))
+				      (just (funApp toEnumName [funApp fromIntegralName [var "val"]]))
+				      nothing)
+			   , funApp pow2Series [intLit (length enums), intLit st]
+			   ]
+		  ]
+
+    rhsGen = 
+          dataCon (mkConName (tdef_name ++ "List__"))
+    		  [ funApp mapMaybeName
+		  	   [ lam [patVar "val"]
+			   	 (hIf (binOp Eq (binOp And (var "val") (var "x"))
+					       (var "val"))
+				      (just (funApp toEnumName [var "val"]))
+				      nothing)
+			   , hList (map (enumToIntExpr fromIntegralName) enums)
+			   ]
+		  ]
+
+\end{code}
+
+Helpers:
+
+\begin{code}
+{- UNUSED
+mkGuard :: Bool -> Haskell.Expr -> EnumValue -> (Haskell.Expr, Haskell.Expr)
+mkGuard long_enum_tags v (EnumValue i val) =
+  (binOp Eq v val', ret (dataConst (mkConName (mkHaskellTyConName nm))))
+  where
+   nm   = idName i
+   val' =
+    case val of
+      Left  il -> intLit il
+      Right e  -> funApp (mkQVarName hdirectLib (if long_enum_tags then "toInt32" else "toInt16")) 
+		         [coreToHaskellExpr e]
+-}
+
+enumToInt :: Bool -> EnumValue -> Haskell.CaseAlt
+enumToInt long_enum_tags ev@(EnumValue i _) = 
+   alt (patKind (mkConName (mkHaskellTyConName nm))) val
+ where
+  patKind
+    | has_args  = \ x -> patRec x []
+    | otherwise = \ x -> conPat x []
+
+  has_args = (idAttributes i) `hasAttributeWithName` "hs_tyarg"
+
+  nm  = idName i
+  val = enumToIntExpr coerce ev
+  coerce = mkQVarName hdirectLib (if long_enum_tags then "toInt32" else "toInt16")
+
+enumToIntExpr :: QualName -> EnumValue -> Haskell.Expr
+enumToIntExpr coerce (EnumValue _ v) =
+   case v of
+     Left il -> intLit il
+     Right e -> funApp coerce [coreToHaskellExpr e]
+
+-- Assume: always called with (Left i)
+intToEnum :: EnumValue -> Haskell.CaseAlt
+intToEnum (EnumValue i (Left v)) = alt (litPat (iLit v)) tag
+ where
+  nm                = idName i
+  tag
+    | has_args      = dataCon tag_nm def_vals
+    | otherwise     = dataConst tag_nm
+  tag_nm            = mkConName (mkHaskellTyConName nm)
+
+  def_vals          = 
+     	(\ x -> 
+	  case x of 
+	   [] -> []
+	   xs -> [lit (LitLit xs)]) $
+     	   unwords $
+	   map (\ xs -> '(':xs ++ ")") $
+	   map getStr $
+           filterAttributes (idAttributes i)
+     			    ["hs_default"]
+
+  getStr (Attribute _ [ParamLit (StringLit s)]) = s
+  getStr _ = ""
+  has_args          = (idAttributes i) `hasAttributeWithName` "hs_tyarg"
+
+intToEnum eVal = error ("intToEnum: unhandled enum RHS -- " ++ showCore (ppEnumValue eVal))
+\end{code}
+
+\begin{code}
+genDerivedEnumInstanceFor :: EnumKind -> [EnumValue] -> Bool
+genDerivedEnumInstanceFor (EnumProgression 0 1) vs 
+  = not (any (\ x -> idAttributes (enumName x) `hasAttributeWithName` "hs_tyarg") vs)
+genDerivedEnumInstanceFor _ _	= False
+\end{code}
+ src/MarshallFun.lhs view
@@ -0,0 +1,177 @@+%
+% (c) The Foo Project, University of Glasgow, 1999
+%
+% @(#) $Docid: Nov. 24th 2003  09:56  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Marshalling procedures/function values
+
+
+\begin{code}
+module MarshallFun ( marshallFun ) where
+
+import BasicTypes
+import Attribute
+import Literal
+import LibUtils
+import CgMonad
+
+import qualified AbstractH as Haskell ( HDecl )
+import AbsHUtils
+
+import CoreIDL
+import CoreUtils
+
+import MarshallType
+import MarshallServ   ( cgServMethod )
+import MarshallMethod ( cgMethod )
+import MarshallCore
+
+import Maybe
+
+\end{code}
+
+
+@marshallFun@ performs two major tasks:
+
++ generates the marshalling code reqd. to deal
+  with function values / callbacks.
++ generates the wrapper code needed for exposing
+  Haskell functions (i.e., non COM) to the outside
+  world.
+
+As elsewhere, the Haskell code generating code is pig ugly.
+
+\begin{code}
+marshallFun :: Maybe Name -> Id -> Type -> CgM Haskell.HDecl
+marshallFun mb_mod_nm i (FunTy cc res ps)
+  | exportFun = do
+     h     <- setInterfaceFlag StdFFI (cgServMethod i real_result ps False False)
+     return (andDecls [m_decl, e_decl, h])
+  | otherwise = do
+     h   <- setInterfaceFlag StdFFI (cgServMethod i real_result ps False False)
+     d   <- setInterfaceFlag StdFFI (cgMethod (i{idName=uw_name}) cc real_result ps
+     					      Nothing (Just i_name))
+     let decl_list = imp_decls ++ exp_decls
+     ds  <- mapM exportDecl decl_list
+     return (andDecls (ds ++ [d,h]))
+ where
+  exportFun     = isJust mb_mod_nm
+
+  imp_decls = 
+    [ (u_name, u_decl)
+    , (i_name, i_decl)
+    , (re_name, re_decl)
+    , (s_name,  s_decl)
+    ]
+
+  exp_decls = 
+    [ (m_name, m_decl)
+    , (e_name, e_decl)
+    , (wr_name, wr_decl)
+    ]
+
+   {- If we're marshalling a function pointer, drop the pointer
+      off the result.
+   -}
+  real_result = res{resultType=res_ty, resultOrigType=res_orig_ty}
+  res_ty      = removePtr (resultType res)
+  res_orig_ty = removePtr (resultOrigType res)
+
+  name      = mkVarName (idName i)
+  v_name    = mkHaskellVarName (idName i)
+
+  m_name 
+    | not exportFun = qName (prefix marshallPrefix name)
+    | otherwise     = qName (appendStr "_proxy" name)
+
+  e_name 
+    | not exportFun = qName (prefix "export_" name)
+    | otherwise     = m_name
+  i_name    = qName (prefix "import_" name)
+  w_name    = mkWrapperName (qName name)
+  wr_name   = qName (prefix marshallRefPrefix name)
+  re_name   = qName (prefix unmarshallRefPrefix name)
+  uw_name   = qName (prefix "unwrap_" name)
+  u_name    = qName (prefix unmarshallPrefix name)
+
+  isPure    = not exportFun && (idAttributes i) `hasAttributeWithName` "pure"
+
+  (ty, mb_c) = toHaskellMethodTy isPure False False Nothing ps real_result
+  base_ty    = toHaskellBaseMethodTy True ps real_result
+   -- base_ty is the type sig of the call-ins, i_base_ty is for
+   -- the call-out. They may differ in that the latter can be
+   -- passed ForeignObjs, while the former receives the FO args
+   -- in Addr form.
+  i_base_ty  = toHaskellBaseMethodTy False ps real_result
+
+  m_decl    = m_tysig `andDecl` m_def
+  m_tysig   = genTypeSig m_name mb_c m_type
+  m_def     
+    | not exportFun = funDef m_name [patVar v_name] m_rhs
+    | otherwise     = funDef m_name [] m_rhs
+  m_rhs     
+    | not exportFun = funApply (var e_name) [funApply (var w_name) [var v_name]]
+    | otherwise     = funApply (var w_name) [varName f_name]
+
+  m_type
+    | exportFun     = ty
+    | otherwise     = funTy ty (io (tyPtr ty))
+
+  wr_decl   = wr_tysig `andDecl` wr_def
+  wr_tysig  = genTypeSig wr_name mb_c wr_type
+  wr_type   = funTy (tyPtr (tyPtr ty)) $
+              funTy ty                 $
+	      io_unit
+  wr_def    = funDef wr_name [patVar "fptr", patVar v_name] wr_rhs
+  wr_rhs    = 
+     bind (funApply (var m_name) [var v_name]) (var "ptr") $
+     funApp w_ptr [var "fptr", var "ptr"]
+
+  e_decl    = fexport cc e_loc e_name e_ty
+
+  e_prim_ty = funTy base_ty (io (tyPtr ty))
+
+   {- Name of the *Haskell* function. -}
+  f_name    = 
+       case (findAttribute "entry" (idAttributes i)) of
+         Just (Attribute _ (ParamLit (StringLit x) : _)) -> mkQVarName mb_mod_nm x
+	 _ -> mkQVarName mb_mod_nm (idName i)
+
+  (e_loc, e_ty)
+    | exportFun = (Just (idName i), base_ty)
+    | otherwise = (Nothing, e_prim_ty)
+
+
+  i_decl    = primcst cc i_name (funTy (tyPtr ty) i_base_ty)
+  		      has_structs c_ty_args c_res_ty
+
+  u_decl    = u_tysig `andDecl` u_def
+  u_tysig   = genTypeSig u_name mb_c (funTy (tyPtr ty) (io ty))
+  u_def     = funDef u_name [patVar "fptr"] u_rhs
+  u_rhs     = ret (funApply (var uw_name) [funApply (var i_name) [var "fptr"]])
+
+  re_decl   = re_tysig `andDecl` re_def
+  re_tysig  = genTypeSig re_name mb_c (funTy (tyPtr ty) (io ty))
+  re_def    = funDef re_name [] re_rhs
+  re_rhs    = var u_name
+
+  s_name   = qName (prefix sizeofPrefix name)
+  s_decl   = s_tysig `andDecl` s_def
+  s_tysig  = typeSig s_name tyWord32
+  s_def    = funDef s_name [] s_rhs
+  s_rhs    = szType addrTy
+
+  has_structs = any (fst) ls
+  ls@(c_res_ty:c_ty_args) = map (isStruct.toCType) (res_ty:p_tys)
+     where
+       isStruct (Left x)  = (False, x)
+       isStruct (Right x) = (True, x)
+
+  p_tys     = map paramType ps
+
+  w_ptr    = prefix marshallRefPrefix (mkQVarName hdirectLib ptrName)
+
+marshallFun _ _ _ = error "marshallFun"
+\end{code}
+ src/MarshallJNI.lhs view
@@ -0,0 +1,264 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 2nd 2003  07:49  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Generating marshalling code for Haskell COM servers.
+
+\begin{code}
+module MarshallJNI 
+	( 
+	  cgJNIMethod
+	, cgJNIInterface
+	, cgJNIClass
+	, cgClassNameDecl
+	) where
+
+import CoreIDL hiding ( Expr(..), CaseLabel(..) )
+import BasicTypes
+import AbstractH hiding ( Type(..) )
+import AbsHUtils
+import CoreUtils
+import MarshallCore
+import Attribute
+import Literal
+import CgMonad
+import LibUtils
+import PpCore ( showCore, ppType )
+import Opts
+	( optOneModulePerInterface
+        )
+
+import Monad ( when )
+import Maybe ( mapMaybe )
+import Utils ( splitLast, snoc )
+
+\end{code}
+
+\begin{code}
+cgJNIMethod :: Id -> Result -> [Param] -> CgM HDecl
+cgJNIMethod i res params = do
+  iface <- getIfaceName
+  as    <- getIfaceAttributes
+  addExport (ieValue (idName i))
+  return (mkJNIMethod i iface res params as)
+
+mkJNIMethod :: Id -> String -> Result -> [Param] -> [Attribute] -> HDecl
+mkJNIMethod i iface res params iface_attrs = m_decl
+ where
+  name        = idName i
+  m_name      = name
+  m_orig_name = idOrigName i
+  attrs       = idAttributes i
+
+  m_decl      = m_tysig `andDecl` m_def
+  m_tysig     = mkTypeSig m_name param_tys (io res_ty)
+
+  m_def       = funDef m_name m_pats m_rhs
+
+  res_ty      = 
+    let r_ty = toHaskellTy True (resultOrigType res) in
+    if isCtor then
+       groundTyVars r_ty
+    else
+       r_ty
+
+  param_tys   = map (paramToHaskellType [] False False False) params `snoc` objParamTy
+
+  isGetField  = attrs `hasAttributeWithName` "jni_get_field"
+  isSetField  = attrs `hasAttributeWithName` "jni_set_field"
+  isStatic    = attrs `hasAttributeWithName` "jni_static"
+  isInterface = not (iface_attrs `hasAttributeWithName` "jni_class")
+  isFinal     = attrs `hasAttributeWithName` "jni_final"
+  isCtor      = attrs `hasAttributeWithName` "jni_ctor"
+
+  isStaticGetField = isGetField && isStatic
+  isStaticSetField = isSetField && isStatic
+
+  objParamTy 
+    | isStatic    = mkTyConst jniEnv
+    | isCtor      = mkTyConst jniEnv
+    | isInterface = let 
+                       tyv = tyVar "a"
+		       nm  = mkHaskellTyConName iface
+		       qnm
+		        | optOneModulePerInterface = mkQualName (Just nm) nm
+			| otherwise		   = mkQualName Nothing nm
+		    in
+		    mkTyCon jObject
+		       [ctxtTyApp (ctxtClass qnm [mkTyCon jObject [tyv]])
+			          tyv]
+    | otherwise   = tyQCon Nothing (mkHaskellTyConName iface) [obj_ty_arg]
+   where  
+    obj_ty_arg
+     | isFinal   = tyUnit
+     | otherwise = tyVar "a"
+
+  m_rhs
+    | isStaticGetField  = funApp getStaticField [ var cls_cls_name, meth_name, ty_spec ]
+    | isStaticSetField  = funApp setStaticField [ var cls_cls_name, meth_name, ty_spec, tup m_args ]
+    | isGetField        = funApp getField [ meth_name, ty_spec ]
+    | isSetField        = funApp setField [ meth_name, ty_spec, tup m_args ]
+    | isCtor      = funApp newObj    [ var cls_cls_name, ty_spec, tup m_args ]
+    | isStatic    = funApp invokeStaticMethod invoke_static_args
+    | isInterface = funApp invokeInterfaceMethod [ meth_name, ty_spec, tup m_args ]
+    | otherwise   = funApp invokeMethod [ meth_name, ty_spec, tup m_args ]
+
+  cls_cls_name = mkClassName (mkHaskellVarName iface)
+
+  invoke_static_args = 
+          [ var cls_cls_name
+	  , meth_name
+	  , ty_spec
+	  , tup m_args
+	  ]
+
+  ty_spec
+   | isGetField = stringLit (toTyDesc (resultType res))
+   | otherwise  = stringLit (mkJavaTypeSpec params res)
+
+  meth_name 
+    | isGetField = stringLit stripped_m_name
+    | isSetField = stringLit stripped_m_name
+    | otherwise  = stringLit m_orig_name
+   where
+    (_:_:_:_:stripped_m_name) = m_orig_name
+
+  m_args    = map (\ p -> var (idName (paramId p))) params
+  m_pats    = map (patVar.idName.paramId) params
+
+\end{code}
+
+\begin{code}
+mkJavaTypeSpec :: [Param] -> Result -> String
+mkJavaTypeSpec ps res = '(':concatMap tyParam ps ++ ')':tyRes res
+ where
+   tyParam p = toTyDesc (paramType p)
+   tyRes  r  = toTyDesc (resultType r)
+
+toTyDesc :: Type -> String
+toTyDesc ty = 
+   case ty of
+       Integer Short _     -> "S"
+       Integer Long  _     -> "I"
+       Integer Natural  _  -> "I"
+       Integer LongLong  _ -> "J"
+       String{}            -> "Ljava/lang/String;"
+       Name _ _ _ _ (Just t) _ -> toTyDesc t
+       Name n _ _ _ _ _    -> 'L':trans n ++ ";"
+       Iface _ _ n _ _ _ -> 'L':trans n ++ ";"
+       Float Short -> "F"
+       Float Long  -> "D"
+       Bool        -> "Z"
+       Octet       -> "B"
+       Char _      -> "C"
+       Void	   -> "V"
+       Array t _   -> '[':toTyDesc t
+       _	   -> error ("toTyDesc: unknown type " ++ showCore (ppType ty))
+
+ where
+  trans x = map dotToSlash x
+
+  dotToSlash '.' = '/'
+  dotToSlash x   = x
+\end{code}
+
+\begin{code}
+cgClassNameDecl :: Id -> (HDecl, Name)
+cgClassNameDecl i = (cls_name_tysig `andDecl` cls_name_def, cls_cls_name)
+ where
+   name	          = idName i
+   attrs	  = idAttributes i
+   h_nm           = mkHaskellTyConName (snd (splitLast "." name))
+   cls_cls_name   = mkClassName (mkHaskellVarName h_nm)
+   cls_name_tysig = typeSig cls_cls_name (mkTyCon className [ty_arg])
+   ty_arg
+    | attrs `hasAttributeWithName` "jni_class" = mkTyCon (mkQualName Nothing h_nm) [tyUnit]
+    | otherwise				       = tyUnit -- for an interface.
+
+   cls_name_def   = funDef cls_cls_name [] cls_name_rhs
+   cls_name_rhs   = funApp makeClassName [stringLit (idOrigName i)]
+
+cgJNIInterface :: Id
+	       -> Bool
+	       -> CgM HDecl
+cgJNIInterface i ignore_decls = do
+   when (not ignore_decls) $ do
+        addExport (ieClass (mkHaskellTyConName name))
+        addExport (ieValue cls_cls_name)
+   let
+    ds 
+     | ignore_decls = emptyDecl
+     | otherwise    = class_decl `andDecl` cls_nm_decl
+
+   return ds
+ where
+   class_decl = hClass ctxt cls_name [tvar] []
+
+   name	      = idName i
+
+   (cls_nm_decl, cls_cls_name) = cgClassNameDecl i
+
+   cls_name   = mkClsName name
+
+   mkClsName n = mkConName (mkHaskellTyConName n)
+
+   tvar       = mkTyVar "a"
+   attrs      = idAttributes i
+   is         = 
+    case (findAttribute "jni_implements" attrs) of
+      Just (Attribute _ [ParamLit (StringLit s)]) -> words s
+      _ -> []
+
+   ctxt       = CtxtTuple (map (\ x -> CtxtClass (mkClsName x) [tyVar "a"]) is)
+
+\end{code}
+
+\begin{code}
+cgJNIClass :: Id
+	   -> Bool
+	   -> CgM HDecl
+cgJNIClass i incl_type_defs 
+ | incl_type_defs = return iface_inst_decls
+ | otherwise      = do
+   addExport (ieValue cls_cls_name)
+   addExport (ieValue ctor_name)
+   return (andDecls [cls_name,default_ctor, iface_inst_decls])
+  where
+   attrs = idAttributes i
+   nm    = idOrigName i
+   h_nm  = mkHaskellTyConName (snd (splitLast "." nm))
+
+   (cls_name, cls_cls_name) = cgClassNameDecl i
+   obj_ty_open    = tyCon (mkHaskellTyConName h_nm) [tyVar "a"]
+
+   default_ctor   = ctor_tysig `andDecl` ctor_def
+   ctor_tysig = typeSig ctor_name
+		        (funTy (mkTyConst jniEnv)
+			       (io (tyCon h_nm [tyUnit])))
+
+   ctor_def   = funDef ctor_name [] ctor_rhs
+   ctor_rhs   = funApp newObj [ var cls_cls_name
+			      , stringLit "()V"
+			      , tup []
+			      ]
+   ctor_name  = "new" ++ h_nm 
+
+   iface_inst_decls = andDecls (map declInstance ifaces_implemented)
+
+   ifaces_implemented = mapMaybe toNm (filterAttributes attrs ["jni_interface"])
+     where
+      toNm  (Attribute _ [ParamLit (StringLit s)]) = Just s
+      toNm  _					   = Nothing
+
+   declInstance n = hInstance Nothing (mkQConName hmod haskell_nm) obj_ty_open []
+     where
+      hmod 
+        | optOneModulePerInterface = Just haskell_nm
+	| otherwise                = Nothing
+
+      haskell_nm = mkHaskellTyConName (snd (splitLast "." n))
+
+\end{code}
+ src/MarshallJServ.lhs view
@@ -0,0 +1,203 @@+%
+% (c) 1999, sof
+%
+% @(#) $Docid: Feb. 9th 2003  15:02  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Generating Haskell-side proxies for HJOs (Haskell implemented
+Java objects.)
+
+\begin{code}
+module MarshallJServ ( cgJServMethod, cgJClass ) where
+
+import CoreIDL
+import Attribute
+import qualified AbstractH as Haskell ( Type )
+import CoreUtils
+import PpCore ( showCore, ppType )
+
+-- code/defs to generate Haskell code:
+
+import AbstractH   ( HDecl )
+import AbsHUtils
+
+import MarshallUtils
+import MarshallJNI
+
+import CgMonad
+
+-- utility libraries:
+import BasicTypes
+import Utils   ( snoc )
+import LibUtils
+
+\end{code}
+
+\begin{code}
+cgJServMethod :: Id
+	      -> Result
+	      -> [Param]
+	      -> CgM HDecl
+cgJServMethod i res params = do
+  cls_name <- getIfaceName
+  return ( helpStringComment i `andDecl` marshallMethod i cls_name params res )
+ 
+\end{code}
+
+The JNI library lets you export Haskell IO actions to Java by tupling
+up the arguments. For the automatically generated proxies we 'un-curry'
+the arguments before applying them to the Haskell method.
+
+\begin{code}
+marshallMethod :: Id
+	       -> String
+	       -> [Param]
+	       -> Result
+	       -> HDecl
+marshallMethod i cls_name params res 
+  | is_ignorable = emptyDecl
+  | otherwise    = ty_sig `andDecl` def
+ where
+  nm           = mkWrapperName (idName i)
+  attrs	       = idAttributes i
+
+  is_ignorable = hasAttributeWithNames 
+  			attrs
+  			[ "jni_get_field"
+			, "jni_set_field"
+			, "jni_ctor"
+			]
+
+  ty_sig      = genTypeSig nm ctxt
+  			      (funTy method_ty        $
+  			       funTy (tuple arg_tys') $
+			       funTy thisTy (io res_ty'))
+  def         = funDef nm pats rhs
+  pats        = [patVar "meth", tuplePat arg_pats, patVar "this"]
+  rhs         = funApp (mkVarName "meth") (arg_exprs `snoc` var "this")
+
+  thisTy      = tyCon cls_name [tyVar "a"]
+
+  (res_ty':arg_tys', ctxt) = generaliseTys (res_ty:arg_tys)
+
+  method_ty   = foldr funTy (funTy thisTy (io res_ty')) arg_tys'
+
+  res_ty      = toJNIType (resultOrigType res)
+
+  arg_exprs   = map var arg_names
+  arg_pats    = map patVar arg_names
+  arg_names   = zipWith (\ _ x -> "arg" ++ show x) arg_tys [(0::Int)..]
+  arg_tys     = map (toJNIType.paramType) params
+
+\end{code}
+
+Converting an IDL type to a corresponding Haskell type is
+not too much work:
+
+\begin{code}
+toJNIType :: Type -> Haskell.Type
+toJNIType t = 
+  case t of
+    Integer sz signed  -> mkIntTy sz signed
+    Float Short        -> tyFloat
+    Float Long         -> tyDouble
+    Float _	       -> error "toJNIType: unsupported Float size"
+    Char _             -> tyWord16
+    Bool               -> tyBool
+    Octet              -> tyByte
+    Object             -> mkTyCon jObject [tyVar "a"]
+    String{}           -> tyString
+    Name _ _ _ _ (Just ty) _ -> toJNIType ty
+    Pointer _ _ ty     -> toJNIType ty
+    Array ty []        -> mkTyCon jArray [toJNIType ty]
+    Void                 -> tyUnit
+    Iface nm imod _ attrs _ _
+      | not (attrs `hasAttributeWithName` "jni_iface_ty") -> tyQCon imod nm [tyVar "a"]
+      | otherwise  -> 
+		    let 
+                       i  = tyVar "a"
+		    in
+		    mkTyCon jObject
+		       [ctxtTyApp (ctxtClass (mkQualName imod nm)
+		       			     [mkTyCon jObject [i]])
+			          i]
+
+    _ -> error ("toJNIType: unknown type " ++ showCore (ppType t))
+
+-- Convert a method's type into its Haskell equivalent.
+toHaskellMethodTy :: Haskell.Type -> Decl -> Haskell.Type
+toHaskellMethodTy obj_ty meth = funTys ps_tys (funTy obj_ty (io res_ty))
+  where
+    res_ty = toJNIType (resultType (methResult meth))
+    ps_tys = map (toJNIType.paramType) (methParams meth)
+\end{code}
+
+\begin{code}
+cgJClass :: Id
+	 -> [Decl]
+	 -> CgM HDecl
+cgJClass i ds 
+ | is_interface = cgJNIInterface i False
+ | otherwise = do
+  addExport (ieValue ctor_nm)
+  addExport (ieValue cls_cls_name)
+  return (cls_nm_decl `andDecl` ty_sig `andDecl` decl)
+  where
+    is_interface = not ((idAttributes i) `hasAttributeWithName` "jni_class")
+
+    ty_sig = mkTypeSig ctor_nm ctor_param_tys ctor_res_ty
+    decl   = funDef ctor_nm ctor_params rhs
+
+    cls_nm = idName i ++ "Proxy"
+    i'     = i{idOrigName=cls_nm}
+
+    (cls_nm_decl, cls_cls_name) = cgClassNameDecl i'
+
+    ctor_nm = "new_" ++ idName i
+
+     -- only interested in the 'real' methods here.
+    ms   = filter (\ d -> isMethod d && not (isIgnorable d)) ds
+
+    ctor_param_tys = map (toHaskellMethodTy obj_ty) ms
+    ctor_params    = map (varPat.methArg) meth_idxs `snoc` varPat env
+
+    ctor_res_ty = funTy (mkTyConst jniEnv) (io fptr_ty)
+
+    obj_ty  = mkTyCon (mkQualName (idModule i) (idName i)) [tyVar "a"]
+    fptr_ty = mkTyCon (mkQualName Nothing  (idName i)) [tyUnit]
+
+    rhs  = foldr (\ f acc -> f acc) res xs
+
+    res  = funApp newObj [ clsName, tySpec, tup x_ms, env ]
+    xs   = zipWith exportMethod ms meth_idxs
+
+    clsName = var cls_cls_name
+    tySpec  = stringLit tySpec_lit
+    env     = var "env"
+    
+    tySpec_lit = '(':ty_args ++ ")V"
+
+    ty_args = concat $ map (\ _ -> functionPtrTySpec) ms
+
+    functionPtrTySpec = "LFunctionPtr;"
+
+    x_ms = map xMethArg meth_idxs
+
+    meth_idxs  = zipWith const [(1::Int)..] ms
+
+    exportMethod d mi =
+      bind (funApp newFPointer [funApp (mkWrapName d) [methArg mi], env])
+           (xMethArg mi)
+	
+
+    xMethArg mi = var ("xm_" ++ show mi)
+    methArg  mi = var ("meth_" ++ show mi)
+
+    mkWrapName d = mkVarName (mkWrapperName (idName (declId d)))
+
+    isIgnorable d = 
+     hasAttributeWithNames (idAttributes (declId d))
+     			   ["jni_set_field", "jni_get_field", "jni_ctor"]
+
+\end{code}
+ src/MarshallMethod.lhs view
@@ -0,0 +1,1078 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Nov. 24th 2003  10:04  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+The marshalling of an IDL method
+
+\begin{code}
+module MarshallMethod 
+	( cgMethod
+	, cgProperty
+
+        , findParamDependents
+	, removeDependers
+	, removeDependees
+	, removeDependents
+	, allocateOutParams
+	, marshallParams
+	, freeInParamStorage
+	, primDecl
+	, mkResult
+	) where
+
+import BasicTypes
+import Literal    ( iLit, Literal(..), IntegerLit(..) )
+import AbstractH  ( HDecl )
+import qualified AbstractH as Haskell ( Expr, Type )
+import NativeInfo ( lONG_SIZE )
+import AbsHUtils
+import Attribute
+import Env	 ( lookupEnv, replaceElt )
+import Opts      ( optKeepHRESULT, optUseDispIDs,
+		   optCoalesceIsomorphicMethods, optPrefixIfaceName,
+		   optSubtypedInterfacePointers, 
+		   optHaskellToC, optIgnoreHiddenMeths, optIgnoreRestrictedMeths,
+		   optGenDefs, optExplicitIPointer, optHugs, optDualVtbl,
+		   optLongLongIsInteger, optCorba, optNoShareFIDs, optCom
+		 )
+import CoreIDL
+import CoreUtils ( DependInfo, DepVal(..),
+		   findParamTy, findParam, isSimpleTy, addrTy,
+		   mkHaskellVarName, mkHaskellTyConName, mkIfaceTypeName,
+		   removePtrAndArray, computeArrayConstraints, removePtrAll,
+		   isVoidTy, isPtrPointerTy, resultParam,
+		   lookupDepender, mkParam, toCType, keepValueAsPointer,
+		   isHRESULT, removePtr, sizeAndAlignModulus,
+		   binParams, tyFun, word32Ty, iUnknownTy,
+		   iPointerParam, isIntegerTy, isIfaceTy
+		 )
+import CgMonad
+import MarshallMonad
+import MarshallType  ( marshallType
+		     , unmarshallType
+		     , refUnmarshallType
+		     , allocPointerTo
+		     , coreToHaskellExpr
+		     , mbFreeType 
+		     , szType
+		     , coerceTy
+		     , coerceToInt
+		     )
+import MarshallCore  ( toHaskellTy
+		     , paramToHaskellType
+		     , toHaskellBaseTy
+		     , toHaskellBaseMethodTy
+		     , autoTypeToHaskellTy
+		     , constrainIIDParams
+		     )
+import MarshallDep
+import MarshallUtils
+import MarshallAuto
+import LibUtils ( comLib
+		, iDispatch
+		, iUnknown
+		, ioExts
+		, outPrefix
+		, autoLib
+		, allocBytes
+		, fromIntegralName
+		, fromMaybeName
+		, mapName
+		, mkPrimitiveName
+		, mkPrimExportName
+		, invokeAndCheck
+		, primInvokeIt
+		, invokeAndCheck
+		, invokeIt
+		, marshallPrefix
+		, withForeignPtrName
+		, check2HR
+		, checkHR
+		)
+
+import Maybe  ( fromMaybe, isJust, fromJust )
+import Monad       ( when, mplus )
+import Utils	   ( concMaybe )
+
+\end{code}
+
+\begin{code}
+cgMethod :: Id 
+	 -> CallConv 
+	 -> Result 
+	 -> [Param] 
+	 -> Maybe Int 
+	 -> Maybe Name  -- name which implements the external call.
+	 -> CgM HDecl
+cgMethod i cconv result params offs mb_prim =
+  -- fetch some state out of the monad and go..
+ getDeclName $ \ mname -> do 
+ dname     <- getDllName 
+ iface     <- getIfaceName
+ objFlag   <- getInterfaceFlag
+ forClient <- getClientFlag
+ isIEnum   <- getIEnumFlag
+ methNo    <- getMethodNumber offs
+ inh       <- getIfaceInherit
+ hasIso    <- 
+    (if (not optCoalesceIsomorphicMethods)
+      then return Nothing
+      else isIsomorphicMethod (idOrigName i) result params)
+ let
+        isObj      = objFlag /= StdFFI
+        isAuto     = 
+	   case objFlag of
+	     ComIDispatch isDual ->
+ 	         not isDual || (not optDualVtbl && permissibleAutoSig result params)
+	     _ -> False
+        isServer   = 
+		not forClient &&
+		not (attrs `hasAttributeWithName` "source")
+
+ case hasIso of
+   Just False  -- already generated code for isomorphic method, so 
+	       -- don't generate code for this one.
+    | optCoalesceIsomorphicMethods -> return emptyDecl
+   _ 
+    | isHidden -> return emptyDecl -- ToDo: support this for binary interfaces??
+    | otherwise -> do
+      {- methods that are marked with call_as() are only
+         used when generating proxy/stub code for remoting.
+	 We use them when in 'COM mode' too, since these methods
+	 have at times attributes that are more helpful to us.
+	 [No, afraid not - the signature of the remoting 
+	  method does not have to be isomorphic to the local
+	  method. See comment in the desugaring code.]
+
+	 In non-COM mode, call_as() is used as a means to
+	 avoid having to have a 1-1 mapping between Haskell
+	 function stub names and the name of the external
+	 entry point to invoke.
+      -}
+    let
+    	meth_i	    = i
+        meth_nm	    = ieValue (mkHaskellVarName (idName meth_i))
+	export_decl = addExport meth_nm
+	
+	enum_meth_ok = isIEnum && not isServer && isIEnumOK
+
+    export_decl
+    (flg, prim_decl, mb_prim2) <- primDecl isObj isServer (not enum_meth_ok && not isAuto)
+    					   i dname mname cconv r_ty params
+    let decl'       = mkMethod iface mname inh hasIso objFlag enum_meth_ok isServer
+    				     mb_prim mb_prim2
+				     cconv methNo meth_i result params
+        decl        = helpString `andDecl` decl'
+    case (isAuto || enum_meth_ok || isJust mb_prim) of
+      True  -> return decl  -- the primitives are elsewhere!
+      False -> do
+	   needStubs flg
+	   hasPrims
+	   return ( decl `andDecl` prim_decl )
+  where
+   r_ty	       = resultType result
+   attrs       = idAttributes i
+
+   isHidden =
+     attrs `hasAttributeWithName` "ignore" || 
+     (( optIgnoreHiddenMeths || optIgnoreRestrictedMeths ) &&
+       attrs `hasAttributeWithNames` ["hidden", "restricted"])
+   
+   helpString = helpStringComment i
+
+   {-
+    Some typelibs are in such a pitiful state, so we have to make
+    sure that the enum method is in a good enough shape. 
+    
+   -}
+   isIEnumOK    = 
+	case idName i of
+	_:'e':'x':'t':_ -> right_shape
+	_:'e':'m':'o':'t':'e':'N':'e':'x':'t':_ -> right_shape
+	_ -> True
+    where
+     right_shape = [In,Out,Out] == map (paramMode) params
+
+
+     
+\end{code}
+
+The function that does the real work of generating a stub. It is
+currently a mess, and is scheduled for a cleanup/rewrite Real Soon.
+
+\begin{code}
+mkMethod :: Name        -- interface the method belongs to
+         -> String      -- it's module
+	 -> [QualName]  -- interface inheritance (name) chain
+	 -> Maybe Bool
+	 -> IfaceType
+	 -> Bool
+	 -> Bool
+	 -> Maybe Name
+	 -> Maybe Name
+	 -> CallConv
+	 -> Int          -- method number (in vtbl)
+	 -> Id           -- method Id / name.
+	 -> Result
+	 -> [Param]
+	 -> HDecl
+mkMethod iface mname inh hasIso objFlag isIEnum isServer
+	 mb_prim mb_prim_nm cconv methNo methId result params 
+  | isAuto     = auto_tysig `andDecl` auto_def
+  | isIEnum    = enum_tysig `andDecl` enum_def
+  | otherwise  = m_tysig    `andDecl` m_def
+      
+  where
+   r_ty	    = resultType result
+   isObj    = objFlag /= StdFFI
+   (isAuto, isDual) =
+     case objFlag of
+       ComIDispatch isD -> (not isD || (not optDualVtbl && permissibleAutoSig result params), isD)
+       _	        -> (False, False)
+
+   m_name      = mkHaskellVarName name
+   name        = idName methId
+
+   m_tysig     = mkTypeSig m_name in_tys result_ty
+   m_def       = funDef m_name in_pats m_rhs
+
+   auto_tysig  = mkTypeSig m_name
+			   in_tys
+   			   (funTy i_pointer_ty (returnType (tuple res_ty)))
+
+   enum_def    = funDef m_name in_pats enum_rhs
+   enum_tysig  = mkTypeSig m_name enum_type_args enum_type_res
+
+   enum_elt_ty = toHaskellTy True (removePtrAndArray (paramType (head results)))
+
+   (enum_type_args, enum_type_res) =
+     let
+       (res_type:is) = (result_ty:in_tys)
+--OLD: (r_ty:is) = relabelTypes (result_ty:in_tys)
+     in
+       {- Bad boy, go sit in the corner. -}
+     case name of
+	_:'e':'x':'t':_ -> (is, funTy i_pointer_ty (io (tyList enum_elt_ty)))
+	_:'e':'m':'o':'t':'e':'N':'e':'x':'t':_ -> 
+                           (is, funTy i_pointer_ty (io (tyList enum_elt_ty)))
+	_ -> (is, res_type)
+
+      
+   enum_rhs    = funApp enum_fun args
+     where
+       enum_fun  = mkQVarName comLib ("enum" ++ enumName)
+       
+	{-
+	  When MIDL generates a typelib for the following
+	  
+	     [object,...]
+	     interface IA : IUnknown {
+		[local]
+	        HRESULT f ();
+		[call_as(f)]
+		HRESULT remoteF();
+	     };
+
+	  The type library gets a method named "remoteF". I'm not
+	  sure that this is right, but what can you do?
+	-}
+       enumName =
+         case idOrigName methId of
+	   _:'e':'m':'o':'t':'e':'N':'e':'x':'t':_ -> "Next"
+	   n -> n
+
+	-- peel off two levels of indirection (one for the [out] pointer)
+       elt_ty    = removePtr (paramType (head results))
+       sz_of     = szType elt_ty
+       write_elt = refUnmarshallType stubMarshallInfo elt_ty
+       args      = 
+	    -- too beautiful, man..
+         case name of
+	   _:'e':'x':'t':_ -> sz_of : write_elt : the_args
+	   _:'e':'m':'o':'t':'e':'N':'e':'x':'t':_ -> sz_of : write_elt : the_args
+	   _ -> the_args
+
+       the_args = 
+          case (map (mkHVar.paramId) meth_params) of
+	    []    -> []
+	    [x]    -> [x]
+		-- the library impl of Skip() and Next() expects a Word32 as first
+		-- arg, so make sure that's the case here.
+	    (x:xs) -> coerceTy (paramType (head meth_params)) word32Ty x : xs
+
+   auto_def    = funDef m_name in_pats auto_rhs
+   auto_rhs    = funApp call_wrapper the_args
+     where
+       fun_id
+         | with_dispids = integerLit dispid
+	 | otherwise    = stringLit (idOrigName methId)
+
+       with_dispids = optUseDispIDs && has_dispid
+       call_wrapper = classifyCall methId with_dispids params result
+
+       the_args
+         | optExplicitIPointer = args ++ [var "iptr"]
+	 | otherwise           = args
+
+       args = fun_id :
+              (hList (map marshallVariantParam ins)):
+              map unmarshallVariantParam  (results)
+
+       has_dispid    = isJust mb_dispid
+       mb_dispid     = getDispIdAttribute (idAttributes methId)
+       (Just dispid) = mb_dispid
+
+   (pars, ins,outs,inouts,res) = binParams params
+
+   param_names = map (idName.paramId) params
+
+   returnType t
+     | isPure    = t
+     | otherwise = io t
+
+   isPure = (idAttributes methId) `hasAttributeWithName` "pure"
+
+   meth_params = 
+     case mb_prim of
+       Nothing -> meth_params'
+       Just _  -> prim_param:meth_params'
+
+    -- extend the param list if the 'result' parameter, so that
+    -- we can use the result in dependent argument expression (
+    -- e.g., [out,length_is(result)]int* f, ...
+   params_and_result 
+     = params ++ [resultParam (resultType result)]
+
+   (prim_params, meth_params', result_ty)
+    | isAuto
+                  = ( []
+		    , real_params ++ (if optExplicitIPointer then [iptr_param] else [])
+		    , funTy i_pointer_ty (returnType (tuple res_ty))
+		    )
+    | isObj || isIEnum
+	          = ( mptr_param:iptr_param:params
+		    , real_params ++ [iptr_param]
+		    , funTy i_pointer_ty (returnType (tuple res_ty))
+		    )
+    | otherwise = 
+                  ( params
+		  , real_params
+		  , returnType (tuple res_ty)
+		  )
+
+	 
+   i_pointer_ty
+     | optSubtypedInterfacePointers && not isIsoMethod
+     = tyCon (mkHaskellTyConName (mkIfaceTypeName iface)) [tyVar "a"]
+
+     | (isAuto || isDual) && isIsoMethod && optSubtypedInterfacePointers
+     = mkTyCon iDispatch [tyVar "a"]
+
+     | isIsoMethod && optSubtypedInterfacePointers
+     = mkTyCon iUnknown [tyVar "a"]
+
+     | isAuto && isIsoMethod
+     = mkTyConst iDispatch
+
+     | optSubtypedInterfacePointers
+     = tyCon (mkHaskellTyConName (mkIfaceTypeName iface)) [tyVar "a"]
+
+     | otherwise
+     = tyConst (mkHaskellTyConName iface)
+
+   isIsoMethod = fromMaybe False hasIso
+
+   -- building the Haskell type of the method/function.
+   (in_tys_1, res_ty) = 
+      constrainIIDParams
+		  (paramToHaskellType par_deps isServer isAuto False)
+                  (paramToHaskellType res_deps isServer isAuto True)
+		  real_params
+		  results
+{-
+   res_ty = map (paramToHaskellType res_deps isServer isAuto True) results
+-}
+   in_tys = 
+	     -- if the primitive method is passed in as arg, prefix it
+	     -- to the parameter list.
+           (if isJust mb_prim then 
+	         ((toHaskellBaseMethodTy False prim_params result):)
+	      else
+	         id) in_tys_1
+--	   map (paramToHaskellType par_deps isServer isAuto False) real_params
+
+   in_p_tys = map (\ p -> ( idName (paramId p)
+   			  , toParamPrimTy isServer p
+			  )
+			  ) prim_params
+
+   iptr_param       = iPointerParam iface
+   mptr_param       = mkParam "methPtr" In
+                               (Pointer Ptr True Void)
+   prim_param       = mkParam (fromJust mb_prim) In
+                               (tyFun cconv result prim_params)
+
+   in_pats     = map (varPat.mkHVar.paramId) meth_params
+
+   meth_result = mkResult results
+
+   unsafeWrap e
+      | isPure    = funApp (mkQVarName ioExts "unsafePerformIO") [e]
+      | otherwise = e
+
+   m_rhs       =
+    unsafeWrap $      
+      runMm (Just (mkHaskellVarName (idName methId))) param_names meth_result $ do
+          marshallDependents False{-not inside struct-} False{-not for server proxies-}
+	  		     par_deps (findParamTy params_and_result) -- in and in-out params
+          allocateOutParams (raw_inout_deps++raw_out_deps) 
+			    (findParam params_and_result)
+			    (removeDependees raw_inout_deps outs)
+          marshallParams True{-marshall-} False isServer (removeDependents in_deps real_ins)
+          marshallParams True{-marshall-} False isServer (removeDependers raw_inout_deps raw_inouts)
+          setupMethodCall isObj methNo iface inh result in_p_tys
+	  		  (thePrimCall isObj mname mb_prim mb_prim_nm methId result prim_params)
+	  freeInParamStorage in_deps ins
+          okResult isObj methId result 
+          unmarshallOutParams isServer (removeDependers (out_deps ++ inout_deps) real_outs)
+	  when (not ignoreResult)
+	       (unmarshallResult isServer methId{idName=outPrefix++idName methId} r_ty)
+          marshallParams False False isServer (removeDependers (inout_deps++out_deps) real_inouts)
+          unmarshallDependents False True out_deps    (findParamTy params_and_result)
+          unmarshallDependents False False inout_deps (findParamTy params_and_result)
+
+   (results, ignoreResult) =
+      let results' 
+	    | isAuto    = (outs ++ inouts)
+	    | otherwise = real_res
+      in	   
+      case r_ty of
+        Void -> (results', True)
+	_ 
+	  | (isHRESULT result && not optKeepHRESULT) ||
+	    ((idAttributes methId) `hasAttributeWithName` "hs_ignore_result")
+	     -> (results', True)
+	  | otherwise -> (results' ++ [res_param], isSimpleTy r_ty && not (isIfaceTy r_ty))
+
+   res_param = 
+      let p = mkParam (outPrefix ++ name) Out r_ty in
+      p{ paramOrigType=resultOrigType result
+       , paramId=(paramId p){idAttributes=idAttributes methId}
+       }  -- replace attributes.
+      
+   (real_params, par_deps)    = findParamDependents True pars
+   (_, in_deps)               = findParamDependents True ins
+   (real_ins, _)             = findParamDependents False ins
+     -- For the [out] params, there's a wondrous special case:
+     --   [out,size_is(x),length_is(*px)]void* pv
+     --
+     -- Here we don't want to unmarshall pv into a list (it's
+     -- really a chunk of mem), but want to consider pv to
+     -- be a dependent argument for the purposes of allocating
+     -- a chunk of memory to pass in. So, use a pair of DependInfos,
+     -- one to use for marshalling ('out_deps') and another
+     -- to use when allocating out-param storage ('raw_out_deps.')
+   (real_outs', out_deps)    = findParamDependents True outs
+   (_, raw_out_deps)         = findParamDependents False outs
+   real_outs                 = filter (not.(`hasAttributeWithName` "ptr").idAttributes.paramId) real_outs'
+   (real_inouts, inout_deps) = findParamDependents False inouts
+   (raw_inouts, raw_inout_deps) = findParamDependents True inouts
+   (real_res, res_deps)         = findParamDependents True res
+\end{code}
+
+Generating code for dispinterface properties is real straightforward,
+
+
+\begin{code}
+cgProperty :: Id -> Type -> Id -> Id -> CgM HDecl
+cgProperty i ty seti geti = do
+  if_name <- getIfaceName
+  let
+   prop_iface_ty
+     | optSubtypedInterfacePointers = tyCon if_name [tyVar "a"]
+     | otherwise		    = tyConst if_name
+
+   get_prop_tysig = mkTypeSig get_prop_name
+			      [prop_iface_ty]
+   			      (io (prop_ty Out))
+
+   set_prop_tysig = mkTypeSig set_prop_name
+			      [prop_ty In, prop_iface_ty]
+   			      (io tyUnit)
+
+   prop_ty kind = autoTypeToHaskellTy kind ty
+
+   get_prop_decl  = funDef get_prop_name [] get_prop_rhs
+   set_prop_decl  = funDef set_prop_name [varPat (var "prop")] set_prop_rhs
+
+   get_prop_name  = if_prefix ++ idName geti
+   set_prop_name  = if_prefix ++ idName seti
+
+   if_prefix
+     | optPrefixIfaceName = mkHaskellVarName (mkIfaceTypeName if_name) ++ "_"
+     | otherwise	  = ""
+
+   get_prop_rhs   = funApp getProp [ prop_id, hList []
+			           , marshallVariant "out" ty
+			           ]
+   set_prop_rhs   = funApp setProp [ prop_id
+				   , hList [funApply (marshallVariant "in" ty) [var "prop"]]
+			           ]
+   prop_id 
+    | optUseDispIDs && has_dispid = integerLit d_id
+    | otherwise			  = stringLit (idName i)
+
+   setProp  = mkQVarName autoLib ("propertySet" ++ dispid)
+   getProp  = mkQVarName autoLib ("propertyGet" ++ dispid)
+
+   has_dispid  = isJust mb_dispid
+   mb_dispid   = getDispIdAttribute (idAttributes i)
+   (Just d_id) = mb_dispid
+
+   dispid
+    | optUseDispIDs = "ID"
+    | otherwise     = ""
+
+  return ( get_prop_tysig `andDecl`
+           get_prop_decl  `andDecl`
+	   set_prop_tysig `andDecl`
+           set_prop_decl
+	 )
+
+\end{code}
+
+
+\begin{code}
+marshallParams :: Bool -> Bool -> Bool -> [Param] -> Mm ()
+marshallParams marsh don'tFree isServer ps = do
+   sequence (map marshallParam ps)
+   return ()
+  where
+   marshallParam p
+    |  isVoidTy ty
+    || isSimpleTy ty 
+    || keepValueAsPointer ty -- keep pointers to complex types
+			     -- external.
+    = return ()
+
+    | otherwise  = 
+	let  nm   = idName (paramId p)
+	     nm'  = "in__" ++ nm
+	     pats
+	      | isIntegerTy ty = tuplePat [patVar (nm ++ "_hi"), patVar (nm ++ "_lo")]
+	      | otherwise      = patVar nm
+	     pats' 
+	      | isIntegerTy ty = tuplePat [patVar (nm' ++ "_hi"), patVar (nm' ++ "_lo")]
+	      | otherwise      = patVar nm'
+	in
+	  -- The hack to prefix the value with res__ in the proxy/server case 
+	  -- requires that the same thing is done in MarshallServ.marshallMethod.meth_result
+	  --
+	  -- Ditto for in__ prefixing the result of unmarshaling proxy args; 
+	  -- MarshallServ.marshallMethod needs to be in on this (less-than-tasteful) game.
+	if isServer 
+	 then if marsh
+	       then let res__nm = var ("res__" ++ nm) in
+	            if (paramMode p == InOut)
+	             then addCode (bind_ (funApply (marshaller p ty) [ var nm, res__nm ]))
+		     else addCode (bind  (funApply (marshaller p ty) [res__nm]) res__nm)
+	       else if (paramMode p == InOut)
+	             then addCode (genBind (funApply (marshaller p ty) [var nm]) pats')
+		     else addCode (genBind (funApply (marshaller p ty) [var nm]) pats)
+         else addCode (genBind (funApply (marshaller p ty) [var nm]) pats)
+      where
+       ty = paramType p
+
+   marshaller p
+    | marsh     = marshallType   stubMarshallInfo{forInOut=(paramMode p == InOut), forProxy=isServer}
+    | otherwise = unmarshallType stubMarshallInfo{ forInOut=(paramMode p == InOut)
+    						 , doFree=not (don'tFree || don'tFree_t)
+						 , forProxy=isServer
+						 }
+           where
+	     don'tFree_t = (idAttributes (paramId p)) `hasAttributeWithName` "nofree"
+
+
+unmarshallOutParams :: Bool -> [Param] -> Mm ()
+unmarshallOutParams isServer ls = do
+   sequence (map (unmarshallOutParam isServer) ls)
+   return ()
+
+unmarshallOutParam :: Bool -> Param -> Mm ()
+unmarshallOutParam isServer p
+ | isVoidTy ty           || 
+   keepValueAsPointer ty ||
+   isPtrPointerTy ty 
+
+{- doesn't make sense.
+   (optHaskellToC   &&
+    isAbstractTy ty &&
+    not (isAbstractFinalTy ty))
+-}
+    = return ()
+
+ | otherwise =
+   addCode (bind (funApply (unmarshallType stubMarshallInfo{ forInOut=(paramMode p == InOut)
+   							   , doFree=not don'tFree
+							   , forProxy=isServer}
+					   ty) [nm]) nm)
+ where
+  ty = paramType p
+  nm = var (idName (paramId p))
+  don'tFree = (idAttributes (paramId p)) `hasAttributeWithName` "nofree"
+
+
+unmarshallResult :: Bool -> Id -> Type -> Mm ()
+unmarshallResult _ _ Void  = return ()
+unmarshallResult isServer i   ty  = 
+   addCode (bind (funApply (unmarshallType stubMarshallInfo{doFree= not don'tFree, forProxy=isServer} ty) [nm]) nm)
+   where
+     nm		= var (idName i)
+     don'tFree  = (idAttributes i) `hasAttributeWithName` "nofree"
+
+allocateOutParams :: DependInfo -> (Name -> Param) -> [Param] -> Mm ()
+allocateOutParams deps lookup_param params = do
+  sequence (map allocate params)
+  return ()
+ where
+   allocate p
+     | isVoidTy ty = return ()
+     | otherwise   = addCode (bind allocOut (var nm))
+    where
+     i	      = paramId p
+     ty	      = paramType p
+     ty'      = removePtrAll ty
+     nm       = idName i
+
+     allocOut =
+       case (lookupDepender deps i) of
+         Nothing -> allocPointerTo ty
+	 Just ls -> 
+	 	let
+		 (_,_,sz_allocs) = computeArrayConstraints False{-not unmarshaling-} ls
+		in
+	         -- allocate space big enough to hold what function is going
+		 -- to return back, i.e.,
+                 --        [out]int*    -> allocBytes s[Int32]  (returning pointer to it.)
+		 --        [out]int**   -> allocBytes s[t*]
+		 --
+		 -- Note: if the [out] param is a constructed type, we don't need to 
+		 -- to allocate space for the objects pointed to by any embedded pointers
+		 -- (that's the task of the callee.)
+		 --  [ No need to plug the pointers with NULLs either, AFAIK. -- sof 5/98 ]
+		 --		    
+		 -- 
+		 -- ToDo: assert that the ty is of a pointer or array nature.
+		case sz_allocs of
+		  []			       -> allocPointerTo ty
+		  (DepNone:_)		       -> allocPointerTo ty
+		    -- The next case is wrong, even if we've got
+		    -- [size_is(*e)] pinned onto an [out] parameter,
+		    -- we'll need to allocate enough space to hold 
+		    -- (*e) elements.
+		  --(DepVal _  (Unary Deref _):_) -> allocPointerTo addrTy
+		  (DepVal Nothing  e:_) -> 
+		  	case ty' of
+			  Pointer _ _ Void -> funApp allocBytes [coerceToInt e]
+			  _ ->
+			    funApp allocBytes
+				   [ binOp Mul
+				           (funApp fromIntegralName [szType ty'])
+					   (coerceToInt e)
+			           ]
+		  (DepVal (Just v) e:_) -> 
+			    let
+			     coerce = varName fromIntegralName
+			     h_e    = coreToHaskellExpr e 
+			    in
+			    case paramType (lookup_param v) of
+			      Pointer Unique _ _ -> 
+					funApp allocBytes
+						 [binOp Mul
+						    (funApp fromIntegralName [szType ty'])
+						    (funApp fromMaybeName
+						            [ var "0"
+						            , funApp mapName [coerce, h_e]
+						            ])]
+			      _ -> 
+				let e' = coerceToInt e in
+				case ty' of
+				   Pointer _ _ Void -> funApp allocBytes [e']
+				   _ ->  funApp allocBytes
+					       [ binOp Mul
+						       (funApp fromIntegralName [szType ty'])
+						       e'
+					       ]
+						      
+
+-- parameter list has all (in)out parameters plus function result.
+mkResult :: [Param] -> Haskell.Expr
+mkResult ps =
+  case ps of
+    [p] | isVoidTy (paramType p) -> ret unit
+        | otherwise		 -> ret (mkVal p)
+    _				 -> ret (tup (map mkVal ps))
+ where
+  mkVal p = var (idName (paramId p))
+\end{code}
+
+Create the FFI declaration for the foreign function/object method
+we're interfacing to. If it's a (COM) method, we give it two
+extra Addr arguments, one contains the address of the method, the
+other the interface pointer.
+
+If we end up wanting to perform an indirect callout
+
+\begin{code}
+primDecl :: Bool
+         -> Bool
+	 -> Bool
+	 -> Id
+	 -> String
+	 -> String
+	 -> CallConv
+	 -> Type
+	 -> [Param]
+	 -> CgM (Bool, HDecl, Maybe Name)
+primDecl isObj isServer trySharing f dname mname cc res params
+ | isServer    = do
+     let sig = mkTySig param_h_tys res_hs_ty
+     mb_res <- lookupDynStub sig
+     case mb_res of
+       Just (True,r) | not optNoShareFIDs -> 
+       	   return (False, emptyDecl, Just r)
+       _ -> do
+           when (not optNoShareFIDs) (addDynStub server_nm sig True)
+           return (False, fexport cc  Nothing server_nm server_ty, Nothing)
+ | not isObj   =
+     return (needs_wrapper, prim cc loc_spec prim_nm prim_ty needs_wrapper c_ty_args c_res_ty, Nothing)
+ | otherwise   = do
+     let sig = mkTySig param_h_tys res_hs_ty
+     mb_res <- lookupDynStub sig
+     case mb_res of
+       Just (False,r) | not optNoShareFIDs && trySharing && not has_structs -> do
+	 return (False, emptyDecl, Just r)
+       _      -> do
+                 when (trySharing && not has_structs) (addDynStub prim_nm sig False)
+       	         return ( has_structs
+                        , primcst cc prim_nm prim_ty has_structs c_ty_args c_res_ty
+			, Nothing
+			)
+ where
+  nm           = idName f
+  orig_nm      = idOrigName f
+  attrs        = idAttributes f
+  the_dname    = 
+    case (findAttribute "dllname" attrs) of
+     Just (Attribute _ [ParamLit (StringLit s)]) -> s
+     _ -> dname
+  
+  loc_spec     =
+     case concMaybe (findAttribute "call_as" attrs)
+                    (findAttribute "entry" attrs)   of
+       Nothing					   -> (the_dname, Nothing, orig_nm, Nothing)
+       Just (Attribute _ [ParamVar v])             -> (the_dname, Nothing, v, Nothing)
+       Just (Attribute _ [ParamLit (IntegerLit (ILit _ x))]) -> 
+	    let
+	     stub_nm     = mkPrimitiveName (show x)
+	    in
+	    (the_dname, Just x, stub_nm, sz)
+       Just (Attribute _ [ParamLit (StringLit v)]) -> (the_dname, Nothing, v, Nothing)
+       _ -> (the_dname, Nothing, orig_nm, Nothing)
+
+   {-
+     Hugs' primitives live in an thoroughly flat namespace - if you have got
+     two primitive decls called "prim_foo", the first that's loaded, is used
+     throughout. Better not let that happen here, so we prepend the module
+     name.
+     
+     [I've submitted a fix for this for Hugs98; hopefully it will be included..]
+
+     8/99 - add module prefix on the non-Hugs side too ; otherwise we run into trouble
+            when linking object files that contain identically named stubs.
+   -}
+  prim_nm = mkPrimitiveName (mname ++ '_':nm)
+
+  needs_wrapper = 
+    has_structs || 
+    case loc_spec of
+      (_, Just _, _, _) -> True
+      _		        -> False
+
+  has_structs = any (fst) ls
+  ls@(c_res_ty:c_ty_args) = map (isStruct.toCType) (res:param_tys')
+     where
+       isStruct (Left x)  = (False, x)
+       isStruct (Right x) = (True, x)
+
+  sz
+   | not optGenDefs = Nothing
+   | otherwise      = 
+     case cc of
+       Stdcall -> 
+         let stuff    = map ((sizeAndAlignModulus Nothing).paramType) params
+	     p_sz     = foldl (al_param) 0 stuff
+	     al_param siz (sz_t,_) = 
+		let --sz' = align sz modu  -- hmm
+		    sz_t'
+		      | sz_t < lONG_SIZE = lONG_SIZE -- everything that's less than word size
+						     -- is rounded up to be exactly that.
+		      | otherwise        = sz_t
+		in (siz + sz_t')
+	 in
+	 Just p_sz
+       _       -> Nothing
+   
+
+  server_nm    = mkPrimExportName nm
+
+  server_ty    = 
+     case generaliseTys [prim_ty] of
+       ([t], mb) -> mbCtxtTyApp mb (funTy t (io tyAddr))
+
+  prim_ty      = funTys  param_hs_tys (io res_hs_ty)
+
+  {-
+    We're using toHaskellBaseTy here to map to the *primitive*
+    Haskell representation of an IDL type.
+  -}
+  param_hs_tys
+   | isServer  = tyPtr (uniqueTyVar "a") : param_h_tys
+   | isObj     = 
+       if optCom || attrs `hasAttributeWithName` "finaliser" then
+          tyAddr : tyAddr : param_h_tys
+       else
+          tyAddr : tyAddr : param_h_tys
+   | otherwise = param_h_tys
+
+  (param_h_tys, _) =
+      constrainIIDParams (toPtrTy .(toParamPrimTy isServer))
+                         (toPtrTy .(toParamPrimTy isServer))
+			 params
+			 outs
+
+--   param_h_tys = map (toPtrTy.toParamPrimTy isServer) params
+
+  (_, _, outs, _, _) = binParams params
+
+  param_tys'
+   | isServer  = addrTy:p_tys
+   | isObj     = addrTy:iUnknownTy:p_tys
+   | otherwise = p_tys
+      where
+       p_tys   = map paramType params
+
+  res_hs_ty = toHaskellBaseTy True res
+
+
+toParamPrimTy isServer p
+  | pattrs `hasAttributeWithName` "foreign" = tyForeignObj
+  | otherwise = toHaskellBaseTy (isResult || isServer) (paramType p)
+  where
+    pattrs   = idAttributes (paramId p)
+    mode     = paramMode p
+    isResult = mode == Out   || 
+--	       mode == InOut ||
+ 	       paramDependent p
+
+\end{code}
+
+If we're compiling a COM method, we need to swizzle the function
+pointer out of the interface pointer in order to perform the
+actual call. @setMethodCall@ does this, dereferencing the i-pointer
+(assume it is in scope as @iptr@), binding the function pointer
+to @methPtr@.
+
+\begin{code}
+setupMethodCall :: Bool 
+		-> Int 
+		-> String 
+		-> [QualName]
+	        -> Result 
+		-> [(Name, Haskell.Type)]
+		-> (Haskell.Expr, Maybe Haskell.Expr) 
+		-> Mm ()
+setupMethodCall isObj methNo ifaceName inh result param_tys methCall
+ | not isObj	     = addCode ( binder mCall )
+ | isHRESULT result  = addCode (
+      binder
+         (funApp
+	     invokeAndCheck 
+	         [ lam [varPat methPtr, varPat iptr] mCall
+		 , offset
+		 , iptr
+		 ]))
+ | otherwise = addCode ( binder invokeMethod )
+   where
+    (mCall0, mbRes) = methCall
+    mCall = unravel mCall0
+
+    invokeMethod 
+      | optHaskellToC || optCorba
+      = 		funApp primInvokeIt
+			       [ lam [varPat methPtr, varPat iptr] mCall
+			       , offset
+			       , funApp m_iptr [iptr]
+			       ]
+      | otherwise     = funApp invokeIt
+			       [ lam [varPat methPtr, varPat iptr] mCall
+			       , offset
+			       , iptr
+			       ]
+
+    m_iptr = 
+       case inh of
+         []    -> prefix marshallPrefix (mkQVarName Nothing ifaceName)
+	 (x:_) -> prefix marshallPrefix x
+
+     -- unwrap the ForeignPtrs.
+    unravel cont 
+      = foldr (\ (f,_) acc -> funApp withForeignPtrName [var f, lam  [patVar f] acc])
+    	      cont
+	      fs
+      where fs = filter (isFOTy.snd) param_tys
+
+    binder = 
+      case mbRes of
+        Nothing -> bind_
+	Just v  -> (\ m n -> bind m v n) -- fp; dontcha just love it!
+
+    iptr      = var "iptr"
+    methPtr   = var "methPtr"
+    offset    = lit (iLit methNo)
+
+\end{code}
+
+Call the primitive. Assume that all arguments have been
+marshalled into an appropriate form and that their marshalled
+representations are in scope as the names given in the parameter list. 
+
+\begin{code}
+thePrimCall :: Bool
+            -> String
+	    -> Maybe Name
+	    -> Maybe Name
+	    -> Id
+	    -> Result
+	    -> [Param]
+	    -> (Haskell.Expr, Maybe Haskell.Expr)
+thePrimCall isComMeth mname mb_prim mb_prim_nm f res params
+   | isVoidTy r_ty || (isComMeth && isHRESULT res) = (f_app, Nothing)
+   | otherwise				           = (f_app, Just r_res)
+ where
+   f_app     = funApp (mkVarName meth_name) args
+   r_ty      = resultType res
+   r_res     = var (outPrefix ++ idName f)
+   args      = foldr mkArg [] params
+
+   mkArg p acc = 
+     case paramType p of
+       Integer LongLong _ | optHugs && optLongLongIsInteger
+			  -> var (nm ++ "_lo") : var (nm ++ "_hi") : acc
+       _ -> var nm  : acc
+    where
+     nm = idName (paramId p)
+
+    -- see primDecl comment.
+   fun_nm  = mname ++ '_':idName f
+
+   meth_name =
+     case mb_prim `mplus` mb_prim_nm of
+       Nothing -> mkPrimitiveName fun_nm
+       Just x  -> x
+
+{-
+ The predicate may look a bit odd - check the
+ HRESULT return code if it is *not* an object
+ method. The reason for this is that the HRESULT
+ return code have already been checked for by
+ special object method call wrappers.
+ 
+ If the result has the attribute [usesgetlasterror],
+ then in the event of error, we fish out the return
+ code and msg by calling GetLastError() - Win32 specific,
+ although we could give [usesgetlasterror] a valid
+ interpretation on most Unices too (use errno.)
+
+-}
+okResult :: Bool -> Id -> Result -> Mm ()
+okResult isObj f res
+  | attrs `hasAttributeWithName` "error_handler" = 
+      case findAttribute "error_handler" attrs of
+        Just (Attribute _ [ParamLit (StringLit s)]) ->
+	   addCode (bind_ (funApp (toQualName s) [r_res]))
+	_ -> return ()
+  | isObj = return ()
+  | attrs `hasAttributeWithName` "usesgetlasterror" =
+	addCode (bind_ (funApp check2HR [r_res]))
+  | not (isHRESULT res) = return ()
+  | otherwise = 
+	addCode (bind_ (funApp checkHR [r_res]))
+ where
+  r_res = var (outPrefix ++ idName f)
+  {-
+   Note: for method Ids, the renaming stage has transferred
+   all attributes from the result type onto the method Id, so
+   we don't need to fish out the result type attributes here.
+  -}
+  attrs = idAttributes f
+
+\end{code}
+
+In order to toss some of the input parameters over the fence, the stub
+function may have to marshall 'em and store them in an external, non-moveable heap.
+Before returning from the stub, we make sure that any such allocations are freed
+up.
+
+We currently don't assume the presence of a marshalling arena for the
+allocation of marshalled values, so we cannot free the allocated memory
+in one fell swoop.
+
+\begin{code}
+freeInParamStorage :: DependInfo -> [Param] -> Mm ()
+freeInParamStorage dep_info ps = do
+   sequence (map freeParam ps)
+   return ()
+  where
+   freeParam p
+        -- special fall-thru case for [sequence, length_is()] - sigh.
+    | isJust dep_res && not has_seq = freeDependent i (findParamTy ps) deps
+    | attrs `hasAttributeWithName` "nofree" = return ()
+    | otherwise	     =
+       case (mbFreeType (paramType p)) of
+         Nothing -> return ()
+         Just e  -> addCode (bind_ (funApply e [var (idName (paramId p))]))
+    where
+      i		  = paramId p
+      attrs       = idAttributes i
+      has_seq     = hasSeqAttribute attrs
+      dep_res     = lookupDepender dep_info i
+      (Just deps) = dep_res
+\end{code}
+
+\begin{code}
+isIsomorphicMethod :: String -> Result -> [Param] -> CgM (Maybe Bool)
+isIsomorphicMethod nm res params = do
+  env <- getIsoEnv 
+  case lookupEnv env nm of
+    Nothing   -> return Nothing
+    Just alts ->
+      case break (match) alts of
+        (_,[]) -> return Nothing
+	(as,(flg,r,ps):bs) -> do
+	      setIsoEnv (replaceElt env nm ((False,r,ps):as++bs))
+	      return (Just flg)
+ where
+  len_params = length params
+
+  match (_,r,ps) =
+    resultType r == resultType res && 
+    len_params == length ps		   &&
+    all (\ (p1,p2) -> paramMode p1 == paramMode p2 &&
+		      paramType p1 == paramType p2)  -- ToDo: check attributes too.
+	(zip ps params)
+
+\end{code}
+ src/MarshallMonad.lhs view
@@ -0,0 +1,162 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Jun. 8th 2001  21:45  Sigbjorn Finne $
+% @(#) $Contactid: sof@galconn.com $
+%
+
+
+\begin{code}
+module MarshallMonad
+       ( Mm
+       , runMm
+       , getMethodName
+       , addCode
+       , addToEnv
+       , lookupName
+       
+       , MarshallInfo(..)
+       , proxyMarshallInfo
+       , stubMarshallInfo
+       , structMarshallInfo
+       
+       ) where
+
+import AbstractH ( Expr(..), Pat(..) )
+import qualified Env
+import BasicTypes
+import LibUtils ( prelReturn )
+
+data Mm a = Mm (Maybe String -> NameEnv -> (a, Cont, NameEnv))
+
+type NameEnv = Env.Env String String
+type Cont = Expr -> Expr
+\end{code}
+
+\begin{code}
+runMm :: Maybe String -> [String] -> Expr -> Mm a -> Expr
+runMm methName orig_names hole (Mm act) =
+  case act methName env of
+    (_, econt, _) -> peepHoleTop (econt hole)
+  where
+   env = Env.addListToEnv (Env.newEnv) (zip orig_names orig_names)
+
+peepHoleTop :: Expr -> Expr
+peepHoleTop e = 
+  case e of
+    Apply f [a] -> Apply f [(peepHole a)]  -- catch 'unsafePerformIO action'
+    x	        -> peepHole x
+
+peepHole :: Expr -> Expr
+peepHole e = 
+  case e of
+    Let bndrs e1 -> Let bndrs (peepHole e1)
+    Bind (Apply (Var x) [Var y]) (PatVar z) e2
+      | x == prelReturn && qName y == qName z -> peepHole e2
+    Bind_ e1 e2  -> Bind_ (peepHole e1) (peepHole e2)
+    Bind e1 p e2 -> 
+	let
+	  p_e1 = peepHole e1
+	  p_e2 = peepHole e2
+	  p_e  = Bind p_e1 p p_e2
+	in
+	case p of
+	  PatVar x ->
+	    case p_e1 of
+	       Return (Var y) | qName x == qName y -> p_e2
+	       _ -> 
+		 case p_e2 of
+		   Return (Var y) | qName x == qName y -> p_e1
+		   _ -> p_e
+	  _ -> p_e
+    _ -> e
+
+{- UNUSED
+doMm :: [String] -> Expr -> Mm a -> (a, Expr)
+doMm orig_names hole (Mm act) =
+  case act Nothing env of
+    (v, econt, _) -> (v, econt hole)
+  where
+   env = Env.addListToEnv (Env.newEnv) (zip orig_names orig_names)
+-}
+
+thenMm :: Mm a -> (a -> Mm b) -> Mm b
+thenMm (Mm act) cont = 
+  Mm ( \ env s ->
+        case (act env s) of
+	  (v,cont1, s') -> 
+	    let (Mm b) = cont v in
+	    case b env s' of
+	     (x, cont2, s'') -> 
+	         (x, cont1.cont2, s''))
+
+returnMm :: a -> Mm a
+returnMm v = Mm ( \ _ s -> (v,id,s))
+
+instance Monad Mm where
+  (>>=)   = thenMm
+  return  = returnMm
+
+getMethodName :: Mm (Maybe String)
+getMethodName = Mm (\ nm env -> (nm, id, env))
+
+addCode :: (Expr -> Expr) -> Mm ()
+addCode cont1 = Mm ( \ _ s -> ((), cont1, s))
+
+lookupName :: String -> Mm (Maybe String)
+lookupName nm = Mm ( \ _ env ->
+		      case (Env.lookupEnv env nm) of
+			  Just n  ->  (Just n, id, env)
+			  Nothing ->  (Nothing, id, env))
+
+addToEnv :: String -> String -> Mm ()
+addToEnv src_nm new_nm = 
+  Mm (\ _ env -> 
+        ((), id, Env.addToEnv env src_nm new_nm))
+\end{code}
+
+Marshalling IDL types isn't merely type-directed, it also needs to take
+into account the context, are we generating proxy or stub marshallers,
+for a struct etc. The @MarshallInfo@ encapsulates the context and
+is passed to the functions which implements the marshalling rules.
+
+\begin{code}
+data MarshallInfo
+ = MarshallInfo
+      { forProxy  :: Bool
+      , forStruct :: Bool
+      , forInOut  :: Bool
+      , forRef    :: Bool
+      , doFree    :: Bool
+      }
+
+proxyMarshallInfo :: MarshallInfo
+proxyMarshallInfo =
+   MarshallInfo
+      { forProxy  = True
+      , forStruct = False
+      , forInOut  = False
+      , forRef    = False
+      , doFree    = False
+      }
+
+stubMarshallInfo :: MarshallInfo
+stubMarshallInfo =
+   MarshallInfo
+      { forProxy  = False
+      , forStruct = False
+      , forInOut  = False
+      , forRef    = False
+      , doFree    = False
+      }
+
+structMarshallInfo :: MarshallInfo
+structMarshallInfo =
+   MarshallInfo
+      { forProxy  = False
+      , forStruct = True
+      , forInOut  = False
+      , forRef    = True
+      , doFree    = False
+      }
+\end{code}
+ src/MarshallServ.lhs view
@@ -0,0 +1,623 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Dec. 1st 2003  07:24  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Generating marshalling code for Haskell COM servers.
+
+\begin{code}
+module MarshallServ ( cgServMethod, mkServVTBL, mkServMain ) where
+
+-- IDL representation: 
+import CoreIDL
+import Attribute
+import Literal ( iLit )
+import CoreUtils
+
+-- code/defs to generate Haskell code:
+
+import AbstractH   ( HDecl, Pat )
+import PpAbstractH ( showAbstractH, ppType )
+import AbsHUtils
+
+-- marshalling code: 
+import MarshallMethod
+import MarshallMonad
+import MarshallUtils
+import MarshallType
+import MarshallDep
+import MarshallCore
+
+import CgMonad
+
+-- utility libraries:
+import BasicTypes
+import LibUtils
+import Opts
+	( optKeepHRESULT
+        , optExportListWithTySig
+	, optAnonTLB
+	, optUseStdDispatch
+	, optCom
+        )
+
+-- standard libraries:
+import Monad ( when )
+import Maybe
+
+\end{code}
+
+What it generates:
+
+  interface IA : IU {
+     HRESULT f ([in]int x);
+  };
+
+ primf :: Addr -> Int -> IO HRESULT
+ primf iptr x = do
+     v  <- getIfaceState iptr
+     catch (f x v >> return s_OK)
+	   (\ _ -> return s_FAIL)
+
+ mkIA_vtbl init_state = ....
+
+\begin{code}
+cgServMethod :: Id
+	     -> Result
+	     -> [Param]
+	     -> Bool
+	     -> Bool
+	     -> CgM HDecl
+cgServMethod i result params isSource isDisper = do
+ objFlag   <- getInterfaceFlag
+ let
+        isObj        = objFlag /= StdFFI
+	isDispSource = 
+	   isDisper ||
+	   (isSource && 
+	    case objFlag of { ComIDispatch _ -> True ; _ -> False })
+
+ return ( helpStringComment i   `andDecl` 
+	  marshallMethod i isObj isDispSource result params
+        )
+\end{code}
+
+\begin{code}
+marshallMethod :: Id 
+	       -> Bool
+	       -> Bool
+	       -> Result
+	       -> [Param]
+	       -> HDecl
+marshallMethod i isObj isDispSource result params =
+   server_stub_tysig `andDecl` server_stub_def
+ where
+   m_name      = mkHaskellVarName (name ++ "_meth") -- increased chance of uniqueness..
+   name        = idName i
+
+   r_ty	       = resultType result
+
+   -- The server code is split into two:
+   --   * the method boilerplate (type sig and lhs of method)
+   --   * the method stub that takes care of exposing the
+   --     Haskell method to the outside world.
+   -- 
+
+   server_stub_tysig = genTypeSig server_stub_name meth_ctxt server_stub_type
+   server_stub_type  
+     | isDispSource = funTys [method_ty, tyList tyVariant, tyVar "objState"]
+                           (io (tyMaybe tyVariant))
+     | otherwise    = 
+         case generaliseTys ((returnType stub_res_ty):stub_param_tys) of
+	   ((r:ts),mbc) -> mbCtxtTyApp mbc (funTys ts r)
+   server_stub_def   = funDef server_stub_name server_stub_pats server_stub_rhs
+   server_stub_rhs
+     | isDispSource     = stub_rhs
+     | isHRESULT result = funApp returnHR [stub_rhs]
+     | otherwise        = stub_rhs
+
+   server_stub_pats 
+     | isDispSource = [patVar m_name]
+     | otherwise    = (patVar m_name) : in_stub_pats
+
+   server_stub_name
+     | isObj     = mkPrimitiveName  name
+     | otherwise = mkWrapperName  name
+
+   obj_state_ty   = uniqueTyVar "objState"
+
+   (method_ty,meth_ctxt) = (funTys ps m_res_ty, ctxt)
+      where
+	m_res_ty
+	  | isObj     = funTy obj_state_ty res
+	  | otherwise = res
+
+	(m_ty, ctxt) = toHaskellMethodTy isPure (isDispSource || isObj) False Nothing params result
+        (ps,res)     = splitFunTys m_ty
+
+
+   stub_param_tys = method_ty : stub_tys
+
+   (stub_tys_1, _) = 
+      constrainIIDParams (\ p -> toHaskellBaseTy True (paramType p))
+      			 (\ p -> toHaskellBaseTy True (paramType p))
+			 params
+			 out_params
+
+   stub_tys       = map (groundTyVars {-. (toHaskellBaseTy True)-}) stub_tys_core
+   stub_tys_core
+     | isObj      = toHaskellBaseTy True iUnknownTy : stub_tys_1
+     | otherwise  = stub_tys_1
+
+   stub_res_ty    = toHaskellBaseTy True r_ty
+   stub_res
+     | isObj            = ret unit
+     | isHRESULT result = ret unit
+     | otherwise        = ret meth_result_expr
+
+   stub_rhs
+     | isDispSource = dispatch_rhs
+     | otherwise    = prim_stub_rhs
+
+   prim_stub_rhs  =
+      runMm (Just name) param_names stub_res $ do
+          unmarshallDependents False False in_deps    (findParamTy params)
+          unmarshallDependents False False inout_deps (findParamTy params)
+          marshallParams False{-unmarshall-} True{-don't free-} True{-is server-} (removeDependents in_deps real_ins)
+          marshallParams False  True{-don't free-} True{-is server-} (removeDependers (inout_deps++out_deps) real_inouts)
+          when isObj unmarshallIfacePointer
+          methCall (i{idName=m_name}) meth_result meth_params
+	  when (not ignoreResult) (marshallResult i{idName=outPrefix++idName i} r_ty)
+          marshallDependents True{-inside struct-} True inout_deps (findParamTy params) -- in and in-out params
+          marshallParams True{-marshall-} False True{-is server-} out_params
+          marshallParams True{-marshall-} False True{-is server-} (removeDependers inout_deps real_inouts)
+	  marshallDependents False{-not inside struct-}
+	                     True{-for a proxy-}
+			     out_deps
+			     (findParamTy params)
+          writeOutParams (removeDependees inout_deps outs)
+
+   dispatch_rhs = foldr unmarshallArg (apply m_name) params'
+    where
+      params'
+       | isHRESULT result || isVoidTy (resultType result) = params
+       | otherwise = params ++ [Param (mkId "the_res" "the_res" Nothing 
+					    [AttrMode Out, Attribute "retval" []])
+                                      Out Void Void False]
+
+      apply nm = 
+        funApp (appendStr (show out_arity) applyName)
+	       ((funApply (var nm) in_args) : out_args)
+
+      out_arity = length out_args
+
+      out_args = 
+        map toOutArgName $
+	filter (\ p -> paramMode p /= In) params'
+       where
+         toOutArgName p =
+	   var $ 
+	   case (paramMode p) of
+	     InOut -> "out_" ++ mkHaskellVarName (idName (paramId p))
+	     _     -> mkHaskellVarName (idName (paramId p))
+
+      in_args  = 
+        map (var.mkHaskellVarName.idName.paramId) $
+	filter (\ p -> paramMode p /= Out) params'
+
+      unmarshallArg p acc = 
+        let
+         mode     = paramMode p
+	 t        = paramType p
+	 lam_pat  = mkHaskellVarName (idName (paramId p))
+	 
+	 (msheller, lams) =
+	  case mode of
+	    In    | isIUnknownTy t -> (inIUnknownArgName, [patVar lam_pat])
+	    	  | otherwise      -> (inArgName, [patVar lam_pat])
+	    Out
+	     | isRetVal  -> (retValName, [patVar lam_pat])
+	     | otherwise -> (outArgName, [patVar lam_pat])
+	    InOut        -> (inoutArgName, [patVar lam_pat, patVar ("out_" ++ lam_pat)])
+  
+         isRetVal  = (idAttributes (paramId p)) `hasAttributeWithName` "retval"
+        in
+	contApply (varName msheller) (lam lams acc)
+
+   (meth_params, prim_params)
+    | isObj 
+    = ( real_params ++ [obj_param]
+      , iptr_param:params
+      )
+    | otherwise
+    = ( real_params
+      , params
+      )
+
+   param_names  = map (idName.paramId) params
+   in_stub_pats = map mkPat prim_params
+       where
+         mkPat p
+	   | paramMode p == Out = patVar ("out_" ++ (idName (paramId p)))
+	   | otherwise          = patVar (idName (paramId p))
+
+   iptr_param       = iPointerParam (idName i)
+   obj_param        = objParam (idName i)
+
+   (results, ignoreResult) =
+      let results' = (real_outs ++ real_inouts)
+      in	   
+      case r_ty of
+        Void -> (results', True)
+	_    -> 
+	  case isHRESULT result && not optKeepHRESULT of
+	    True -> (results', True)
+	    _    -> (results' ++ [res_param], isSimpleTy r_ty)
+
+    -- Note: prefixing the result vals with res__ is reqd in the proxy case
+    -- to distinguish it from the name for the out/in-out param (i.e., 'res__foo'
+    -- rather than 'foo'.)
+   (meth_result, meth_result_expr) = 
+     case results of
+       []  -> (Nothing, unit)
+       _   -> (Just (tuplePat (map patVar res_names)), tup (map var res_names))
+         where
+	  res_names = map (("res__"++).idName.paramId) results
+
+   isPure = (idAttributes i) `hasAttributeWithName` "pure"
+
+   returnType t = io t
+
+   res_param = 
+      let p = mkParam (outPrefix ++ name) Out r_ty in
+      p{ paramOrigType=resultOrigType result
+       , paramId=(paramId p){idAttributes=idAttributes i}
+       }  -- replace attributes.
+      
+   out_params = map remPtr (removeDependents out_deps real_outs)
+    where
+     remPtr p 
+       | not (isConstructedTy (nukeNames t') && not (isEnumTy t')) &&
+         not (isVariantTy t') =	
+	 	case paramType p of
+		   Pointer Unique isExp (Pointer _ _ x) -> p{paramType=Pointer Unique isExp x}
+		   _				        -> p{paramType=t'}
+       | otherwise	      = p
+      where
+       t' = removePtr (paramType p)
+
+   (pars, ins,outs,inouts,_) = binParams params
+   (real_params', _)         = findParamDependents False pars
+   (real_ins, in_deps)       = findParamDependents False ins
+   (real_outs, out_deps)     = findParamDependents False outs
+   (real_inouts, inout_deps) = findParamDependents False inouts
+
+   real_params		     = map jiggleInOut real_params'
+   
+    -- the unmarshaling of inout params leaves the results bound to p__in; hence,
+    -- we need to append "__in" to the method parameters here.
+   jiggleInOut p 
+     | paramMode p == InOut  = p{paramId=(paramId p){idName= "in__" ++ idName (paramId p)}}
+     | otherwise             = p
+
+\end{code}
+     
+\begin{code}
+mkServVTBL :: Id -> Bool -> Bool -> [InterfaceDecl] -> CgM HDecl
+mkServVTBL iface_id isDispSource justVTBL decls =
+    getDeclName $ \ mname   -> do
+    dname   <- getDllName 
+    let 
+     meths = filter isMethod decls
+  
+     mkFFIDecl m = do
+	let res              = methResult m 
+	(_, prim_decl,mb_prim) <-
+	       primDecl True{-isObj-} True{-isServer-} True{-try to re-use other decls-}
+		        (declId m) dname mname
+		        (methCallConv m)
+		        (resultType res)
+		        (methParams m)
+	return (prim_decl, mb_prim)
+
+     ffi_decls 
+       | isDispSource = return []
+       | otherwise    = mapM mkFFIDecl meths
+
+    fs_stuff <- ffi_decls
+    let
+     (fs, prim_nms) = unzip fs_stuff
+     
+     mk_vtbl = 
+       genTypeSig mk_vtbl_nm (listToMaybe (catMaybes ctxts))
+       			     (funTys meth_tys mk_vtbl_res_ty) `andDecl`
+       funDef  mk_vtbl_nm mk_vtbl_pats mk_vtbl_rhs
+
+     mk_vtbl_pats   = map (patVar.mkHaskellVarName.idName.declId) meths
+     mk_vtbl_nm     = "mk" ++ qName (vtblName iface_id)
+     mk_vtbl_res_ty = io (mkTyCon comVTableTy [iid_ty, iface_ty])
+    
+
+     mk_vtbl_args   = zipWith (\ _ x -> var ("meth_arg"++show x)) meths [(0::Int)..]
+     mk_vtbl_rhs    = 
+       foldr
+	 (uncurry binder)
+	 (funApp vtbl_creator [(hList mk_vtbl_args)])
+         (zip (zipWith export_prim meths (prim_nms ++ repeat Nothing)) mk_vtbl_args)
+      where
+       binder
+         | isDispSource = \ m v n -> hLet v m n
+	 | otherwise    = bind
+
+       vtbl_creator
+         | isDispSource = createDispVTable
+	 | otherwise    = createComVTable
+
+     iface_ty    = uniqueTyVar "objState" -- needs to be branded 'unique' so that
+     					  -- when we come to constraining type variables
+					  -- for the VTBL methods (Variant overloaded), we
+					  -- leave 'objState' parameter out of it.
+     iid_ty      = tyQCon (idModule iface_id)
+     			  (idName iface_id) [tyUnit]
+
+     (meth_tys, ctxts) =
+       unzip $
+       map (\ m -> toHaskellMethodTy False
+       				     True{- is server -}
+				     False
+				     (Just iface_ty) (methParams m) 
+				     (methResult m))
+           meths
+
+     export_prim m mb_prim_nm
+       | isDispSource = funApp mkDispMethod [ stringLit f_nm, dispid, wrap_up ]
+       | otherwise    = funApply (var prim_nm) [wrap_up]
+      where
+       prim_nm =
+         case mb_prim_nm of
+	   Just x -> x
+	   _      -> mkPrimExportName nm
+
+       i    = declId m
+       f_nm = idOrigName i
+       dispid = 
+          case getDispIdAttribute (idAttributes i) of
+	     Nothing -> lit (iLit (0::Int))
+	     Just il -> integerLit il
+
+       wrap_up = funApply (var (mkPrimitiveName nm)) 
+			  [var (mkHaskellVarName nm)]
+       nm = idName i
+
+    addExport (ieValue mk_vtbl_nm)
+    if justVTBL then
+       return mk_vtbl
+     else do
+       return (andDecls (mk_vtbl:fs))
+
+vtblName :: Id -> QualName
+vtblName i = mkQualName (idModule i) (idName i ++ "_vtbl")
+\end{code}
+
+\begin{code}
+methCall :: Id -> Maybe Pat -> [Param] -> Mm ()
+methCall f mb_res params = 
+  addCode $
+  case mb_res of
+      -- i.e., [pure] has no effect of funs return void.
+      --          [pure]void f(...); => f :: .... -> IO ()
+    Nothing -> bind_ f_app
+    Just p 
+     | isPure    -> \ e -> hCase f_app [alt p e]
+     | otherwise -> genBind  f_app p
+ where
+  isPure    = (idAttributes f) `hasAttributeWithName` "pure"
+  f_app     = funApp (mkVarName meth_name) args
+  args      = map (var.idName.paramId) params
+
+  meth_name = mkHaskellVarName (idName f)
+
+unmarshallIfacePointer :: Mm ()
+unmarshallIfacePointer =
+ addCode (bind (funApp getIfaceState [var iptr]) obj)
+   where
+    obj     = var "obj"
+
+marshallResult :: Id -> Type -> Mm ()
+marshallResult _ Void = return ()
+marshallResult i   ty =
+--   addCode (bind_ (funApply (marshallType proxyMarshallInfo ty) [nm]))
+   addCode (bind (funApply (marshallType proxyMarshallInfo ty) [nm]) nm)
+   where
+     nm		= var ("res__" ++ idName i)
+
+\end{code}
+
+
+\begin{code}
+writeOutParams :: [Param] -> Mm ()
+writeOutParams params = do
+  sequence (map writeOut params)
+  return ()
+ where
+   writeOut p
+     | isVoidTy ty = return ()
+     | otherwise   = addCode (bind_ wOut)
+    where
+     i	      = paramId p
+     ty	      = paramType p
+     ty'      = removeNames (removePtr ty)
+     nm       = idName i
+     
+     resV n = var ("res__" ++ n)
+     
+     wOut 
+      | isSimpleTy ty' 
+      = funApply (refMarshallType proxyMarshallInfo ty') [var ("out_"++nm), resV nm]
+      | isEnumTy ty' || isBoolTy ty'
+      = funApply (refMarshallType proxyMarshallInfo intTy) [var ("out_"++nm), resV nm]
+      | otherwise
+      = case ty' of
+	  Name "VARIANT_BOOL" _ _ _ _ _ | optCom ->
+               funApply (refMarshallType proxyMarshallInfo int16Ty) [var ("out_"++nm), resV nm]
+	  _ -> funApp w_mshall [castPtr (var ("out_"++nm)), resV nm]
+   	where
+	  w_mshall = prefix marshallRefPrefix (mkQVarName hdirectLib ptrKind)
+	  
+	  ptrKind
+	   | isFinalised = fptr
+	   | otherwise   = "Ptr"
+
+	  isFinalised = isFOTy (toHaskellBaseTy False ty')
+
+\end{code}
+
+What's generated for a coclass decl:
+
+\begin{code}
+mkServMain :: String -> Id -> [CoClassDecl] -> CgM HDecl
+mkServMain lib_nm i cdecls = do
+   mapM_ addExp exports
+   return ( register_class     `andDecl` 
+            new_instance       `andDecl`
+	    component_info_def `andDecl`
+	    vtbl_decls         `andDecl`
+	    ifaces_decl	)
+  where
+   addExp (nm,ty)
+    | optExportListWithTySig = addExportWithComment nm (":: " ++ showAbstractH (ppType ty))
+    | otherwise		     = addExport nm
+
+   exports = [ (ieValue component_info_nm, component_info_ty) ]
+
+   class_name = idName i
+   clsid_nm   = mkCLSIDName class_name
+   libid_nm   = mkLIBIDName lib_nm
+
+   implemented_ifaces = filter nonSourceIface cdecls
+   
+   nonSourceIface d = not ((idAttributes (coClassId d)) `hasAttributeWithName` "source")
+
+   component_info_nm    = "componentInfo"
+   component_info_ty    = mkTyConst componentInfo
+   component_info_tysig = typeSig component_info_nm component_info_ty
+   component_info_def   = 
+	    component_info_tysig `andDecl`
+	    valDef component_info_nm component_info_rhs
+
+   component_info_rhs   = 
+    (if usesTlb then
+         \ x -> funApp hasTypeLib [x]
+     else 
+        id) $
+     funApp mkComponentInfo
+	    [ var clsid_nm
+	    , var register_class_nm
+	    , var new_instance_nm
+	    ]
+
+   register_class =
+     register_class_sig  `andDecl`
+     register_class_def
+
+   register_class_sig = typeSig register_class_nm register_class_ty
+   register_class_nm = "register_" ++ class_name
+   register_class_ty = funTys [tyString, tyBool] io_unit
+
+   register_class_def = 
+      funDef register_class_nm [wildPat, wildPat] register_class_rhs
+
+   register_class_rhs = ret unit --ToDo.
+
+   new_instance = 
+      new_instance_sig `andDecl`
+      new_instance_def
+
+   new_instance_sig = typeSig new_instance_nm new_instance_ty
+   new_instance_nm  = "new" ++ class_name
+   new_instance_ty  = 
+    funTy tyString  $
+    funTy (io_unit) $
+    funTy (mkTyCon iID [mkTyCon iUnknown [tyVar "iid"]])
+	  (io (mkTyCon iUnknown [tyVar "iid"]))
+
+   component_mod = Just (idName i)
+   component_new = qvar component_mod "new"
+
+   new_instance_def = funDef new_instance_nm 
+			     [ patVar "dll_path"
+			     , patVar "finaliser"
+			     , patVar "iid"
+			     ]
+			     new_instance_rhs
+   new_instance_rhs = 
+       bind  component_new obj_state $
+       funApp createComInst [dll_path, obj_state, var "finaliser", var ifaces_nm, var "iid"]
+  
+   dll_path  = var "dll_path"
+   obj_state = var "obj_state"
+   ifaces_nm = "ifaces_" ++ class_name
+
+   objStateTy = tyQConst component_mod "State"
+
+   ifaces_decl =
+      ifaces_ty_sig `andDecl`
+      ifaces_def
+
+   ifaces_ty     = tyList (mkTyCon comInterfaceTy [objStateTy])
+   ifaces_ty_sig = typeSig ifaces_nm ifaces_ty
+   ifaces_def = 
+     valDef ifaces_nm
+            ifaces_rhs
+	 
+   usesTlb   = not optUseStdDispatch && any derivesFromIDispatch implemented_ifaces 
+   ifaces_rhs = hList (map mkIface implemented_ifaces)
+   
+   mkIface d
+     | isDual    = funApp mkDualInterface l_args
+     | isAuto    = funApp mkDispInterface l_args
+     | otherwise = funApp mkComInterface    args
+     where
+       isDual = (idAttributes cid) `hasAttributeWithName` "dual"
+       isAuto = derivesFromIDispatch d
+
+       tlb_arg 
+         | optAnonTLB || optUseStdDispatch = nothing
+	 | otherwise  = just (var libid_nm)
+
+       l_args  = (tlb_arg : args)
+       args    = [qvar md ("iid" ++nm), var (vtbl_nm ++ "_vtbl")]
+       cid     = coClassId d
+       md      = idModule cid
+       nm      = idName cid
+       vtbl_nm = mkHaskellVarName nm
+
+   vtbl_decls = andDecls (map mk_vtbl implemented_ifaces)
+   
+   mk_vtbl d = 
+      typeSig vtbl_nm (mkTyCon comVTableTy [iid_ty, objStateTy]) `andDecl`
+      valDef vtbl_nm  vtbl_rhs
+    where
+      iid_ty      = tyQCon (idModule (coClassId d)) 
+      			   (idName (coClassId d)) [tyUnit]
+      vtbl_nm_raw = vtblName (coClassId d)
+      vtbl_nm     = mkHaskellVarName (qName vtbl_nm_raw)
+      vtbl_rhs    = funApp uPerformIO [funApp (prefix "mk" vtbl_nm_raw) meths]
+
+      meths    = 
+        case coClassDecl d of
+	   Nothing  -> error "Stuck"
+	   Just dcl -> 
+               let
+	        decls = 
+		  case dcl of
+		    DispInterface{dispExpandedFrom=ii} | isJust ii -> declDecls (fromJust ii)
+		    _ -> declDecls dcl
+
+	        the_meths = filter (isMethod) decls
+	       in
+	       map ((qvar component_mod).mkHaskellVarName.idName.declId) the_meths
+
+\end{code}
+ src/MarshallStruct.lhs view
@@ -0,0 +1,371 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 9th 2003  08:01  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Generating code for going between IDL structs and
+their Haskell equivalent.
+
+\begin{code}
+module MarshallStruct ( marshallStruct ) where
+
+import BasicTypes ( Name, QualName, qName )
+import Literal ( iLit )
+
+import Attribute
+import AbstractH  ( HDecl )
+import qualified AbstractH as Haskell ( Expr, ConDecl )
+import AbsHUtils
+import LibUtils
+import CgMonad
+
+import CoreIDL
+import CoreUtils
+import MarshallUtils
+import MarshallMonad
+import MarshallType ( refMarshallType
+		    , refUnmarshallType
+		    , unmarshallType
+		    , marshallType
+		    , freeType
+		    , needsFreeing
+		    )
+
+import MarshallDep ( marshallDependents
+		   , unmarshallDependents
+		   )
+import MarshallCore
+import List	   ( findIndex, partition )
+import Maybe	   ( mapMaybe  )
+import Utils	   ( diff, notNull )
+import Opts	   ( optCom )
+
+\end{code}
+
+The marshalling of structs is mostly complete, but here's
+a list of current shortcomings/ToDos:
+
+ - structure layout is very simplistic and wrong.
+ - there's chance of name capture, as the marshalling
+   routines introduce the names "ptr" and "pf"[0-9]+
+ - [ignore] attributes may just work..(lightly tested.)   
+
+\begin{code}
+marshallStruct :: Name 
+	       -> Id 
+	       -> Haskell.ConDecl 
+	       -> [Field] 
+	       -> Maybe Int
+	       -> CgM HDecl
+marshallStruct tdef_name struct_tag datacon fields mb_pack = do
+  ds <- mapM exportDecl decl_list
+  return (andDecls ds)
+ where
+    decl_list =
+      (if needToFree then
+         ((f_name, f_tysig `andDecl`  f_def):)
+       else
+         id) $
+      (if simplStruct then
+         (\ x -> (m_name, m_tysig `andDecl`  m_def):
+                 (u_name, u_tysig `andDecl`  u_def):x)
+       else
+         id)
+      [ (w_name, w_tysig `andDecl`  w_def)
+      , (r_name, r_tysig `andDecl`  r_def)
+      , (s_name, s_tysig `andDecl`  s_def)
+      ]
+
+     {-
+       To be able to marshal stuff like
+       
+         typedef struct { uint64 w ; } ULARGE_INTEGER;     
+     
+       by value, we need to check if this is possible.
+     -}
+    simplStruct = length (fields) == 1 &&
+		  isSimpleTy field_ty
+
+    addRef_fields = isFinalisedType True  (Struct struct_tag fields Nothing)
+    final_fields = isFinalisedType  False (Struct struct_tag fields Nothing)
+
+    [field]    = fields
+    field_ty   = fieldType field
+    field_h_ty = toHaskellBaseTy False field_ty
+    v_field    = var (mkHaskellVarName (idName (fieldId field)))
+
+    name       = mkConName tdef_name
+
+    t_ty       = tyConst tdef_name
+    b_ty       = tyConst tdef_name
+
+    ptr         = var "ptr"
+    pf0         = var "pf0"
+    field_names = map (idName.fieldId) fields
+
+    structCon  = conDeclToCon datacon 
+    structPat  = conDeclToPat datacon
+
+    {-
+      Find out which struct members depend on the value of
+      others.
+    -}
+    dep_list = findFieldDependents fields
+    fields_w = mapMaybe (adjustField True  dep_list) fields
+    fields_r = mapMaybe (adjustField False dep_list) fields
+
+    -- *** Reference marshalling ***
+    w_name     = qName (prefix marshallRefPrefix name)
+    w_tysig    = typeSig w_name w_type
+    w_type
+      | optCom && addRef_fields = funTy tyBool (funTy (tyPtr b_ty) (funTy t_ty io_unit))
+      | otherwise               = funTy (tyPtr b_ty) (funTy t_ty io_unit)
+    w_def      = funDef w_name w_pats w_rhs
+    w_pats
+      | optCom && addRef_fields = [patVar "addRefMe__", varPat ptr, structPat]
+      | otherwise               = [varPat ptr, structPat]
+
+    w_rhs      = runMm Nothing field_names w_rest w_unpack
+    w_rest     = foldr ($) (ret unit) ((hLet pf0 ptr) : w_fields)
+
+    w_fields = zipWith3 (refMarshallField dep_list
+    					  (offsetOfName fields offsets)
+					  (findFieldTy fields))
+		        rel_offsets
+			[(1::Int)..]
+		        (tagLast fields_w)
+
+    w_unpack = marshallDependents True{-inside struct-} False{- for a (client) stub-}
+    				  dep_list (findFieldOrigTy fields)
+      -- here's a hack for you: when writing the contents of a field such
+      --    [size_is(x)]int y[];
+      -- 
+      -- we cannot do the normal trick of first marshalling the Haskell list
+      -- representing 'y' into a chunk of mem. followed by filling in the struct
+      -- with a pointer to it, because the assumed layout is for y[] to be inlined
+      -- into the struct. 
+      -- 
+      -- The solution is to remove such fields from the list that's presented to
+      -- the 'dependent-arg' marshalling code.
+      -- 
+     
+    -- *** Reference unmarshalling ***
+    r_name   = qName (prefix unmarshallRefPrefix name)
+    r_tysig  = typeSig r_name r_type
+    r_type 
+      | final_fields = funTy tyBool (funTy (tyPtr b_ty) (io t_ty))
+      | otherwise    = funTy (tyPtr b_ty) (io t_ty)
+    r_def    = funDef r_name r_pats r_rhs
+    r_pats
+      | final_fields = [patVar "finaliseMe__", varPat ptr]
+      | otherwise    = [varPat ptr]
+    r_rhs    = hLet pf0 ptr r_fields
+    r_fields =
+      foldr
+       ($)
+       (runMm Nothing field_names (ret structCon) r_pack)
+       (zipWith3 (refUnmarshallField (offsetOfName fields offsets)
+				     (findFieldTy fields))
+	         rel_offsets
+		 [(1::Int)..]
+		 (tagLast fields_r))
+
+    r_pack   = unmarshallDependents True False dep_list (findFieldOrigTy fields)
+
+     -- shouldn't really generate the next two..
+    m_name   = qName (prefix marshallPrefix name)
+    m_tysig  = typeSig m_name (funTy t_ty (io field_h_ty))
+    m_def    = funDef m_name [structPat] m_rhs
+    m_rhs    = ret v_field   -- we know it is already in a marshaled form!
+
+    u_name   = qName (prefix unmarshallPrefix name)
+    u_tysig  = typeSig u_name (funTy field_h_ty (io t_ty))
+    u_def    = funDef u_name [varPat v_field] u_rhs
+    u_rhs    = ret structCon -- we know it is already in an unmarshaled form!
+	 
+
+    s_name   = qName (prefix sizeofPrefix name)
+    s_tysig  = typeSig s_name tyWord32
+    s_def    = funDef s_name [] s_rhs
+    -- Not right, struct alignment/pad not taking into consid.
+    s_rhs
+      | null fields = var "0"
+      | otherwise   = var (show sz)
+
+    rel_offsets = diff offsets
+
+    ((sz, _), offsets) = computeStructSizeOffsets mb_pack fields
+
+    -- Freeing a struct.
+    needToFree = needsFreeing (Struct struct_tag fields Nothing)
+    
+    f_name   = qName (prefix freePrefix name)
+    f_tysig  = typeSig f_name (funTy (tyPtr b_ty) (io_unit))
+    f_def    = funDef f_name [varPat ptr] f_rhs
+    f_rhs    = foldr1 (bind_) (map unmarshalTag field_switches ++
+			      (mapMaybe freeField fields_sans_switches))
+
+    (field_switches, fields_sans_switches) =
+       partition (\ (f,_) -> isSwitchDependee dep_list (fieldId f))
+		 (zip fields offsets)
+
+    struct_ptr__ = var "struct_ptr__"
+    field_ptr__  = var "field_ptr__"
+
+    unmarshalTag (f,offset) =
+	  {- unpack the tag of a union, will be needed later when
+	     the union is being freed up.
+	  -}
+	   let v = idName (fieldId f) in
+           bind (funApply (refUnmarshallType structMarshallInfo (toBaseTy (fieldType f)))
+		          [addPtr (var "ptr") (lit (iLit offset))])
+		(var v)
+		(ret unit) -- sigh, shouldn't be forced to do this.
+
+    freeField (f , offset)
+      | not (needsFreeing (fieldType f)) = Nothing
+      | otherwise			 = 
+	 let
+	  ty = fieldOrigType f
+	  e  = freeType ty
+         in
+         Just (hLet struct_ptr__ (addPtr ptr (lit (iLit offset)))
+		    (if (isPointerTy ty) then
+		        (bind (funApp derefPtr [ struct_ptr__ ]) field_ptr__
+			      (funApply e [field_ptr__]))
+		     else
+		        (funApply e [struct_ptr__])))
+
+offsetOfName :: [Field] -> [Int] -> Name -> Int
+offsetOfName fields offsets nm =
+   case (findIndex (\ f -> idName (fieldId f) == nm) fields) of
+     Nothing -> (-1)
+     Just v  -> offsets!!v
+\end{code}
+
+When marshalling the Haskell representation of a "struct"
+into its external representation, @refMarshallField@ takes
+care of generating code to marshall a given field plus
+set up the offset for the code that will unmarshall the
+next "struct" field (if any.)
+
+\begin{code}
+refMarshallField :: DependInfo
+		 -> (Name -> Int)
+		 -> (Name -> Type)
+		 -> Int 
+		 -> Int 
+		 -> (Field, Bool)
+		 -> (Haskell.Expr -> Haskell.Expr)
+refMarshallField dep_list to_offset lookup_ty offset field_no (field, is_last) = \ hole ->
+    hLet pf (addPtr pf_prev (lit (iLit offset))) $
+    bind_ (funApply mshaller args) hole
+  where
+   f_id = fieldId field
+   ty   = fieldType field
+
+    {-
+      The [switch_is(..)] attribute for a field is pinned on the
+      field Id and not the type, so we have to figure the expression
+      which computes the dependee argument here rather than
+      in MarshallType.refMarshallType.
+    -}
+   args 
+    | isNonEncUnionTy ty = [dependee_arg, pf, fi]
+    | otherwise          = [pf, fi]
+
+   dependee_arg =
+    case (getSwitchIsAttribute (idAttributes f_id)) of
+      Just e | notNull fs -> 
+	let v = head fs in
+	funApply (refMarshallType stubMarshallInfo (toBaseTy (lookup_ty v)))
+		 [addPtr (var "pf0") (lit (iLit (to_offset v)))]
+        where
+	 fs = findFreeVars e
+
+      _      -> (lam [wildPat] (ret unit))
+
+   mshaller
+    | isDepender dep_list f_id && 
+      not (isSwitchDepender dep_list f_id) &&
+      not (isArrayTy ty)
+        = refMarshallType structMarshallInfo addrTy
+    | is_last && isArrayTy ty = marshallType structMarshallInfo{forInOut=True} ty
+        {-
+	  If we've got a VARIANT, copy the struct in.
+	  ToDo: add special support for this in TypeInfos.
+	-}
+    | isVariantTy ty = varName (prefix copyPrefix vARIANT)
+    | otherwise      = refMarshallType structMarshallInfo ty
+    
+
+   fi
+    | hasIgnoreAttribute f_id = varName nullPtr
+    | otherwise		      = var (mkHaskellVarName (idName f_id))
+
+   pf      = mkFieldPtrName field_no
+   pf_prev = mkFieldPtrName (field_no - 1)
+
+mkFieldPtrName :: Int -> Haskell.Expr
+mkFieldPtrName field_no = varName (prefix "pf" (mkVarName (show field_no)))
+
+\end{code}
+
+When unmarshalling a "struct" from its external representation
+to its Haskell representation, @refUnMarshallField@ takes
+care of generating code to unpack a given field.
+
+\begin{code}
+refUnmarshallField :: (Name -> Int) 
+		   -> (Name -> Type)
+		   -> Int
+		   -> Int
+		   -> (Field, Bool)
+		   -> (Haskell.Expr -> Haskell.Expr)
+refUnmarshallField to_offset lookup_ty offset field_no (field, is_last) hole =
+  hLet pf (addPtr pf_prev (lit (iLit offset))) (binders hole)
+  where
+   f_id   = fieldId field
+   ty     = fieldType field
+   o_ty   = removeNames (fieldOrigType field)
+
+   fi      = var (mkHaskellVarName (idName f_id))
+   pf      = mkFieldPtrName field_no
+   pf_prev = mkFieldPtrName (field_no -1)
+
+   args 
+    | isNonEncUnionTy ty = [dependee_arg, pf]
+    | otherwise          = [pf]
+
+   dependee_arg =
+    case (getSwitchIsAttribute (idAttributes f_id)) of
+      Just e | notNull fs -> 
+	let v = head fs in
+	funApply (refUnmarshallType structMarshallInfo (toBaseTy (lookup_ty v)))
+		 [addPtr (var "pf0") (lit (iLit (to_offset v)))]
+       where
+        fs = findFreeVars e
+      _ -> ret (lit (iLit ((-1)::Int)))
+
+   binders 
+    | hasIgnoreAttribute f_id = hLet fi (varName nullPtr)
+    | otherwise               = bind (funApply un_marshaller args) fi
+  
+   un_marshaller
+	--
+	-- A special case is VARIANT types, which are represented
+	-- by a pointer to the external VARIANT struct. Hence, we don't
+	-- reference-unmarshal these, but value-unmarshal. Similarly
+	-- with arrays embedded inside structs; marshall them by value.
+    | is_last && isArrayTy o_ty = unmarshallType structMarshallInfo{doFree=True} ty
+    | isVariantTy ty   = unmarshallType structMarshallInfo{doFree=True} ty
+    | otherwise	       = refUnmarshallType structMarshallInfo ty
+
+tagLast :: [a] -> [(a,Bool)]
+tagLast []  = []
+tagLast [x] = [(x,True)]
+tagLast (x:xs) = (x,False) : tagLast xs
+\end{code}
+
+ src/MarshallType.lhs view
@@ -0,0 +1,1137 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Jun. 10th 2003  12:17  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+MarshallType provides the following:
+
+ - converting IDL types to Haskell ones.
+ - functions for generating code that (un)marshalls a value
+   of an IDL type.
+ - marshalling dependent parameter types
+
+\begin{code}
+module MarshallType 
+       (
+	 marshallType
+       , unmarshallType
+       , refMarshallType
+       , refUnmarshallType
+       , szType
+       , allocPointerTo
+       , freeType
+       , mbFreeType
+       , needsFreeing
+
+       , coreToHaskellExpr
+
+       , coerceTy
+       , coerceToInt	      -- :: Expr -> Haskell.Expr
+       
+       ) where
+
+import Prelude hiding ( mod )
+import BasicTypes
+import Attribute
+import Literal
+import LibUtils
+import Utils   ( mapFromMb, trace, notNull )
+
+import qualified AbstractH as Haskell ( Expr(..) )
+--import qualified PpAbstractH as PPHaskell ( showAbstractH )
+import AbsHUtils
+
+import CoreIDL
+import CoreUtils
+import PpCore ( showCore, ppType )
+
+import Maybe ( fromMaybe, isJust, fromJust )
+
+import MarshallCore
+import MarshallMonad
+import Opts  ( optHaskellToC, optLongLongIsInteger,
+	       optCorba, optCom, optNoWideStrings,
+	       optNoDerefRefs
+	     )
+import TypeInfo ( TypeInfo(..) )
+
+\end{code}
+
+%*
+%
+<sect>Marshalling types
+%
+%*
+
+From a given IDL type t we may need to generate calls to functions
+that implement various marshalling operations over type t:
+
+  - marshall,   by-value and by-reference
+  - unmarshall, by-value and by-reference
+  - size of
+  - allocate
+  - release/free
+
+The following functions can be used to do this:
+
+\begin{verbatim}
+marshallType      :: MarshallInfo -> Type -> Haskell.Expr
+refMarshallType   :: MarshallInfo -> Type -> Haskell.Expr
+unmarshallType    :: MarshallInfo -> Type -> Haskell.Expr
+refUnmarshallType :: MarshallInfo -> Type -> Haskell.Expr
+
+szType	  :: MarshallInfo -> Type -> Haskell.Expr
+ -- alloc storage to hold a (fixed size) value of a particular type,
+ -- returning a pointer to it.
+allocPointerTo    :: Type -> Haskell.Expr
+\end{verbatim}
+
+\begin{code}
+marshallType :: MarshallInfo -> Type -> Haskell.Expr
+marshallType mInfo t =
+  case t of
+    Array at [] 
+       | forRef mInfo -> funApp w_list  [ varName false, szType at, refMarshallType mInfo at ]
+       | otherwise    -> funApp m_list  [ szType at, refMarshallType mInfo{forRef=True} at ]
+    Array (Char _) [e] 
+       | forRef mInfo -> funApp w_bstring [ varName false, coreToHaskellExpr e ]
+    Array at [e] 
+       | forRef mInfo -> funApp w_blist [ szType at
+       				        , coreToHaskellExpr e
+					, refMarshallType mInfo{forRef=True} at
+					]
+       | otherwise       -> funApp m_blist
+                                   [ szType at
+    				   , coreToHaskellExpr e
+				   , refMarshallType mInfo{forRef=True} at
+				   ]
+    Array at [mi,ma] -> 
+      funApp m_blist [ szType at
+                     , binOp Sub (coreToHaskellExpr ma)
+		     	         (coreToHaskellExpr mi)
+		     , refMarshallType mInfo{forRef=True} at
+		     ]
+    Pointer _ _ ty | isVoidTy ty -> varName prelReturn
+    Pointer Ptr _ ty
+      | (isConstructedTy (nukeNames ty) && isReferenceTy ty) -> varName prelReturn
+    Pointer pt isExp (Iface nm mod _ attrs _ inh)  ->
+   	case pt of
+	  Unique | optCom && isExp        -> funApp marshallMaybe [ varName m_iptr, varName nullFO ]
+	  	 | optHaskellToC && isExp -> funApp marshallMaybe 
+		 			    [ varName m_ip
+		 			    , varName $
+					       if attrs `hasAttributeWithName` "finaliser" then
+					         nullFO
+					       else
+					         nullPtr
+					    ]
+
+	  _ ->
+	   case inh of
+	     [] | optHaskellToC -> varName m_ip
+		| otherwise     -> varName m_iptr
+	     (x:_) 
+		   | optCorba   -> varName (prefix marshallPrefix (fst x))
+		   | optCom || 
+		     qName (fst x) == "IUnknown" -> varName m_iptr
+		   | otherwise		         -> varName (prefix marshallPrefix (fst x))
+      where
+       m_ip = prefix marshallPrefix (mkQVarName mod nm)
+          
+    Pointer pt _ (Name _ _ _ _ _ (Just ti))
+      | pt /= Ptr && is_pointed ti -> 
+	  let
+	   mshaller 
+	    | forInOut mInfo && finalised ti = varName (copy_marshaller ti)
+	    | otherwise                      = varName (marshaller ti)
+
+           null_elt
+	    | forInOut mInfo && finalised ti = varName nullPtr
+	    | finalised ti                   = varName nullFO
+	    | otherwise		             = varName nullPtr
+	  in
+	  case pt of
+	    Unique -> funApp marshallMaybe [ mshaller, null_elt ]
+	    _      -> mshaller
+
+    Pointer pt _ ty 
+	   | isFunTy ty && pt /= Ptr          -> marshallType mInfo ty
+	   | forInOut mInfo && forProxy mInfo -> refMarshallType mInfo t
+	   | otherwise ->
+	       case pt of
+	        Ptr     -> varName prelReturn
+                Ref     -> funApp m_ref    [ allocPointerTo ty, refMarshallType mInfo{forRef=False} ty ]
+	        Unique  -> funApp m_unique [ allocPointerTo ty, refMarshallType mInfo{forRef=False} ty ]
+    Void         -> varName prelReturn  -- this shouldn't really happen.
+    String _ isUnique _ 
+      | isUnique  -> funApp marshallMaybe [varName m_string, varName nullPtr]
+      | otherwise -> varName m_string
+    Sequence ty mbSz mbTerm
+                  -> funApp m_sequence [ refMarshallType mInfo{forRef=False} ty
+    				       , terminatorElt True mbTerm ty
+				       , szType ty
+				       , case mbSz of 
+				       	   Nothing -> nothing
+					   Just x  -> just (coreToHaskellExpr x)
+				       ]
+    SafeArray{}  -> varName m_safearray
+    WString isUnique _
+      | isUnique  -> funApp marshallMaybe [varName m_wstring, varName nullPtr]
+--      | isUnique  -> funApp marshallMaybe [varName m_wstring, varName nullFO]
+      | otherwise -> varName m_wstring
+    Bool         -> varName m_bool
+    Enum{}       -> varName m_enum32
+
+    Name _ _ _ _ _ (Just ti)   
+       | forInOut mInfo && finalised ti  -> varName (copy_marshaller ti)
+       | otherwise    		         -> varName (marshaller ti)
+    Name _ _ _ _ (Just ty@Enum{}) _ -> marshallType mInfo ty
+    Name _ _ _ _ (Just ty@(Name{})) _ -> marshallType mInfo ty
+    Name nm _ mod _ (Just (Struct i [f] _)) _ 
+       | isSimpleTy (fieldType f) ||
+         ((idAttributes i) `hasAttributeWithName` "hs_newtype")
+       -> qvar mod (marshallPrefix  ++ nm)
+
+    Name nm _ mod _ (Just ty) _ 
+      | isConstructedTy (nukeNames ty) && not (isFunTy ty) -> funApp m_ref [ allocPointerTo t, refMarshallType mInfo{forRef=False} t ]
+      | isFunTy ty                     -> qvar mod (marshallPrefix ++ nm)
+      | otherwise                      -> marshallType mInfo ty
+
+    Struct i fs _
+       | length fs == 1 && isSimpleTy (fieldType (head fs)) &&
+         not ((idAttributes i) `hasAttributeWithName` "hs_newtype")
+       -> qvar (idModule i) (marshallPrefix  ++ idName i)
+       | otherwise  -> funApp m_ref    [ allocPointerTo t, refMarshallType mInfo{forRef=False} t ]
+    Union{}     -> funApp m_ref    [ allocPointerTo t, refMarshallType mInfo{forRef=False} t ]
+    UnionNon{}  -> funApp m_ref    [ allocPointerTo t, refMarshallType mInfo{forRef=False} t ]
+    CUnion{}    -> funApp m_ref    [ allocPointerTo t, refMarshallType mInfo{forRef=False} t ]
+
+    Integer LongLong isSigned
+      | optLongLongIsInteger -> varName (m_integer isSigned)
+    Iface{} -> marshallType mInfo (Pointer Ref True t)
+    _    -> let nm = mkMarshaller marshallPrefix t in
+	    varName nm
+
+  where
+   m_bool    = libImport bool
+   m_string  = libImport stringName
+   m_list    = libImport list
+   m_blist   = libImport blist
+   m_ref     = libImport ref
+   m_unique  = libImport unique
+
+   m_sequence  = libImport "Sequence"
+
+   m_safearray
+     | forProxy mInfo = prefix marshallPrefix sAFEARRAY
+     | otherwise       = prefix marshallPrefix (mkQVarName autoLib safearray)
+   
+   w_list    = prefix marshallRefPrefix (mkQVarName hdirectLib list)
+   w_bstring = prefix marshallRefPrefix (mkQVarName hdirectLib bstring)
+   w_blist   = prefix marshallRefPrefix (mkQVarName hdirectLib blist)
+
+   m_integer isSigned
+     | isSigned  = libImport integer
+     | otherwise = libImport ('U':integer)
+
+   m_enum32  = libImport enum32
+
+   m_iptr        = prefix marshallPrefix iUnknown
+   m_wstring
+    | optNoWideStrings  = wideImport wstring2
+    | otherwise         = wideImport wstring
+
+   libImport nm     = prefix marshallPrefix (mkQVarName hdirectLib nm)
+   wideImport nm    = prefix marshallPrefix (mkQVarName wStringLib nm)
+
+
+terminatorElt :: Bool -> Maybe Expr -> Type -> Haskell.Expr
+terminatorElt forMarshalling mbTerm ty
+ | forMarshalling = lam [patVar "x"] $
+ 			funApp (prefix marshallRefPrefix termTyName)
+			       [ var "x"
+			       , termVal
+			       ] 
+ | otherwise      = lam [patVar "ptr"] $
+ 			bind (funApp (prefix unmarshallRefPrefix termTyName) [var "ptr"])
+			     (var "dx")
+			     (ret (infixOp (var "dx") eqName termVal))
+ where
+  (termVal, termTyName) = 
+    case ty of
+     Char{}    -> (Haskell.Lit (CharLit '\0'), mkQVarName hdirectLib "Char")
+     Integer sz signed ->
+        case mbTerm of
+	  Just e -> (coreToHaskellExpr e, deTyCon $ mkIntTy sz signed)
+	  _      -> (coreToHaskellExpr (Lit (iLit (0::Int))), deTyCon $ mkIntTy sz signed)
+     _         -> (varName nullPtr, mkQVarName hdirectLib "Ptr")
+\end{code}
+
+
+\begin{code}
+unmarshallType :: MarshallInfo -> Type -> Haskell.Expr
+unmarshallType mInfo ty =
+  case ty of
+    Array (Char _) [] -> varName u_string
+	{-
+	  Handling open arrays when unmarshalling is tricky
+	  if you haven't got any information on the size of the
+	  thing. Nontheless, we represent open arrays as lists,
+	  since there's no trouble marshalling a list into an
+	  (open) array - it's this other way which is troublesome.
+	  So..we emit code which tries to marshall *one* element
+	  from the array here. Elsewhere we emit a warning message
+	  that the unmarshaller for a struct containing open arrays
+	  isn't 100% cool. The fix is either to use [size_is()] or
+	  manually tweak the gen'ed code.
+	  
+	  ToDo: add support for the notion of zero terminated vectors?
+	-}
+    Array t [] -> funApp u_single [ refUnmarshallType mInfo{forRef=True} t ]
+    Array (Char _) [e] -> 
+    	  funApp u_bstring [ coreToHaskellExpr e ]
+    Array t [e]
+      | doFree mInfo -> 
+          funApp doThenFree
+             [ freeType ty
+	     , funApp u_list [ szType t
+	                     , var "0"
+	                     , coreToHaskellExpr e
+                             , refUnmarshallType mInfo{forRef=True} t
+	                     ]
+	     ]      
+      | otherwise ->
+          funApp u_list [ szType t
+			, var "0"
+			, coreToHaskellExpr e
+			, refUnmarshallType mInfo{forRef=True} t
+			]
+    Array t [mi,ma]
+       | doFree mInfo ->
+            funApp doThenFree
+                   [ freeType ty
+	           , funApp u_list [ szType t
+	                           , coreToHaskellExpr mi
+	                           , coreToHaskellExpr ma
+                                   , refUnmarshallType mInfo{forRef=True} t
+	                           ]
+	     ]
+       | otherwise ->
+	     funApp u_list [ szType t
+	                   , coreToHaskellExpr mi
+	                   , coreToHaskellExpr ma
+                           , refUnmarshallType mInfo{forRef=True} t
+	                   ]
+    String _ isUnique _ 
+        | doFree mInfo   -> funApp doThenFree [ freeType ty, uString ]
+        | otherwise      -> uString
+       where
+         uString 
+	   | isUnique  = funApp readMaybe [ varName u_string ]
+	   | otherwise = varName u_string
+
+    Sequence t mbSz mbTerm -> 
+    		    funApp u_sequence [ refUnmarshallType mInfo{forRef=False} t
+    				      , terminatorElt False mbTerm t
+				      , szType t
+				      , case mbSz of 
+				       	   Nothing -> nothing
+					   Just x  -> just (coreToHaskellExpr x)
+				      ]
+
+    WString isUnique _ 
+        | doFree mInfo   -> funApp doThenFree [ freeType ty, uString ]
+        | otherwise      -> uString
+       where
+        uString 
+	  | isUnique  = funApp readMaybe [ varName u_wstring ]
+	  | otherwise = varName u_wstring
+
+    Pointer pt isExp t@(Iface nm mod _ attrs _ inh) ->
+	 case pt of   -- see marshallType comment re: raw interface ptrs.
+	   Ptr    | optCom -> u_ipointer
+           Unique | (optCom || optHaskellToC) && isExp ->
+		if forRef mInfo then
+		   funApp u_unique [ refUnmarshallType mInfo{forRef=False} t ]
+		else
+		   funApp u_unique [ unmarshallType mInfo t ]
+	   _   -> 
+ 	    case inh of
+	      [] | optCom        -> u_ipointer
+	         | optHaskellToC && attrs `hasAttributeWithName` "finaliser" ->
+		 		    funApp u_ip [ lit (BooleanLit (not (forProxy mInfo))) ]
+	         | otherwise -> varName u_ip
+	      (x:_) 
+		    | optCorba       -> varName (prefix unmarshallPrefix (fst x))
+		    | optCom || qName (fst x) == "IUnknown" -> 
+		        if forRef mInfo then
+			   refUnmarshallType mInfo{forRef=False} ty
+			else
+			   u_ipointer
+	            | optHaskellToC && attrs `hasAttributeWithName` "finaliser" ->
+		 		    funApply (varName (prefix unmarshallPrefix (fst x)))
+				    	     [ lit (BooleanLit (not (forProxy mInfo))) ]
+		    | otherwise		          -> varName (prefix unmarshallPrefix (fst x))
+      where
+       u_ip = prefix unmarshallPrefix (mkQVarName mod nm)
+
+    Pointer _ _ (Name _ _ _ _ _ (Just ti))
+      | is_pointed ti -> 
+		if finalised ti then
+		   funApply (varName (unmarshaller ti)) [lit (BooleanLit (not (forProxy mInfo))) ]
+		else
+		   varName (unmarshaller ti)
+    Pointer _ _ Void -> varName prelReturn
+    Pointer pt _ t -> 
+      case pt of
+	Ptr
+	 | isIfacePtr t  -> 
+	     if forRef mInfo then
+	        refUnmarshallType mInfo{forRef=False} t
+	     else
+	        u_ipointer
+         | isPointerTy t && doFree mInfo -> funApp doThenFree 
+	                                           [ freeType ty
+	                                           , refUnmarshallType mInfo{forRef=False} t
+						   ]
+         | isPointerTy t -> refUnmarshallType mInfo{forRef=False} t
+	 | otherwise     -> varName prelReturn
+
+        Ref
+          | doFree mInfo -> funApp doThenFree [ freeType ty
+					      , refUnmarshallType mInfo{forRef=False} t
+					      ]
+	  | otherwise    -> refUnmarshallType mInfo{forRef=False} t
+	Unique
+	  | isIfacePtr t -> 
+		if forRef mInfo then
+		   funApp u_unique [ refUnmarshallType mInfo{forRef=False} (getIfaceTy ty) ]
+		else
+		   funApp u_unique [ unmarshallType mInfo (getIfaceTy ty) ]
+
+	  | doFree mInfo -> funApp doThenFree [ freeType ty
+	                                      , funApp u_unique
+	                                               [ refUnmarshallType mInfo{forRef=False} t ]
+					      ]
+	  | otherwise    -> funApp u_unique [ refUnmarshallType mInfo{forRef=False} t ]
+
+    Void -> varName prelReturn
+    Bool -> varName u_bool
+    Name _ _ _ _ _ (Just ti) {-  not (is_pointed ti) -} -> 
+		if finalised ti then
+		   funApply (varName (unmarshaller ti)) [lit (BooleanLit (not (forProxy mInfo))) ]
+		else
+		   varName (unmarshaller ti)
+    Name _ _ _ _ (Just t@Enum{}) _ -> unmarshallType mInfo t
+    Name _ _ _ _ (Just t@(Name{})) _ -> unmarshallType mInfo t
+    Name nm _ mod _ (Just (Struct i [f] _)) _ 
+       | isSimpleTy (fieldType f) || 
+         ((idAttributes i) `hasAttributeWithName` "hs_newtype")
+       -> qvar mod (unmarshallPrefix  ++ nm)
+    Name _ _ _ _ (Just t) _ 
+      | isConstructedTy (nukeNames t) -> refUnmarshallType mInfo{forRef=False} (Pointer Ref True ty)
+    Struct i fs _
+       | (length fs == 1 && isSimpleTy (fieldType (head fs))) ||
+         ((idAttributes i) `hasAttributeWithName` "hs_newtype")
+       -> qvar (idModule i) (unmarshallPrefix  ++ idName i)
+       | otherwise -> refUnmarshallType mInfo{forRef=False} (Pointer Ref True ty)
+    Union{}     -> refUnmarshallType mInfo{forRef=False} (Pointer Ref True ty)
+    UnionNon{}  -> refUnmarshallType mInfo{forRef=False} (Pointer Ref True ty)
+    CUnion{}    -> refUnmarshallType mInfo{forRef=False} (Pointer Ref True ty)
+    Enum{}      -> varName u_enum32
+    Iface{}     -> unmarshallType mInfo (Pointer Ptr True ty)
+    SafeArray{} -> u_safearray
+
+    Integer LongLong isSigned
+      | optLongLongIsInteger -> varName (u_integer isSigned)
+    _       -> let nm = mkMarshaller unmarshallPrefix ty in
+	       varName nm
+  where
+   u_bool    = libImport bool
+   u_string  = libImport stringName
+   u_list    = libImport list
+   u_bstring = libImport bstring
+   u_unique  = libImport unique
+   u_single  = libImport "Single"
+
+   u_sequence  = libImport "Sequence"
+
+   u_safearray
+     | forProxy mInfo  = funApply (varName (prefix unmarshallPrefix sAFEARRAY)) [ lit (BooleanLit False) ]
+     | forStruct mInfo = funApply (varName (prefix unmarshallPrefix sAFEARRAY)) [ lit (BooleanLit False) ]
+     | otherwise       = varName (prefix marshallPrefix (mkQVarName autoLib safearray))
+
+   u_integer isSigned
+     | isSigned  = libImport integer
+     | otherwise = libImport ('U':integer)
+
+   u_enum32 = libImport enum32
+
+   u_iptr       = prefix unmarshallPrefix iUnknown
+   u_ipointer
+    | forInOut mInfo = varName (prefix unmarshallPrefix iUnknownFO)
+    | otherwise      = funApp u_iptr [ lit (BooleanLit (forProxy mInfo)) ]
+
+   u_wstring
+     | optNoWideStrings = wStringImport wstring2
+     | otherwise        = wStringImport wstring
+
+   libImport nm     = prefix unmarshallPrefix (mkQVarName hdirectLib nm)
+   wStringImport nm = prefix unmarshallPrefix (mkQVarName wStringLib nm)
+
+\end{code}
+
+\begin{code}
+refMarshallType :: MarshallInfo -> Type -> Haskell.Expr
+refMarshallType mInfo t = 
+  case t of
+    Array (Char _) [e] -> funApp w_bstring [ varName true,  coreToHaskellExpr e ]
+    Array at [e] -> 
+      funApp w_blist
+	     [ szType at
+	     , coreToHaskellExpr e
+	     , refMarshallType mInfo{forRef=False} at
+	     ]
+    Array at [mi, ma] -> 
+      funApp w_blist
+	     [ szType at
+	     , binOp Sub (coreToHaskellExpr ma)
+	     		 (coreToHaskellExpr mi)
+	     , refMarshallType mInfo{forRef=False} at
+	     ]
+    Array at [] -> funApp w_list [ varName false
+    				 , szType at
+				 , refMarshallType mInfo{forRef=False} at
+				 ]
+
+    SafeArray{} -> varName w_safearray
+    String _ isUnique _ 
+      | isUnique  -> funApp writeMaybe [ varName w_string ]
+      | otherwise -> funApp  w_string  [ varName true ]
+    WString isUnique _ 
+      | isUnique  -> funApp writeMaybe [ varName w_string ]
+      | otherwise -> varName w_wstring
+
+    Sequence ty mbSz mbTerm -> 
+    		     funApp w_sequence [ varName true
+    				       , refMarshallType mInfo{forRef=False} ty
+    				       , terminatorElt True mbTerm ty
+				       , szType ty
+				       , case mbSz of 
+				           Nothing -> nothing
+					   Just x  -> just (coreToHaskellExpr x)
+				       ]
+
+{- Hmm..I'm not sure what is the right thing here - include the
+   Maybe or not. If the Maybe type is used, then MarshallCore.toHaskellTy
+   will need to change accordingly. -}
+    Pointer Unique isExp ty
+      | forRef mInfo              &&
+        (optCom || optHaskellToC) &&
+	isExp                     &&
+	isIfaceTy ty    -> funApp writeMaybe [ w_ip ]
+      where
+       (Iface nm mod _ _ _ _) = getIfaceTy ty
+       w_ip 
+        | optHaskellToC = varName (prefix marshallRefPrefix (mkQVarName mod nm))
+	| otherwise     = funApp w_iptr [w_iptr_arg]
+      
+    Pointer _ _ (Iface nm mod _ _ _ inh) ->
+       case inh of
+         [] | not optHaskellToC -> funApp w_iptr [ w_iptr_arg ]
+	    | otherwise		-> varName w_ip
+	 (x:_) 
+	       | optCorba          -> varName (prefix marshallRefPrefix (fst x))
+	       | not optHaskellToC -> funApp w_iptr [ w_iptr_arg ]
+	       | otherwise	   -> varName (prefix marshallRefPrefix (fst x))
+      where
+       w_ip = prefix marshallRefPrefix (mkQVarName mod nm)
+
+    Pointer pt _ (Name _ _ _ _ _ (Just ti))
+      | pt /= Ptr && is_pointed ti -> 
+	  case pt of
+	    Unique -> 
+	    	if finalised ti then
+		   funApp writeMaybe [ varName (ref_marshaller ti) ]
+		else
+		   funApp writeMaybe [ varName (ref_marshaller ti) ]
+	    _ -> varName (ref_marshaller ti)
+
+    Pointer Ptr _ (Name _ _ _ (Just as) _ _) 
+     | as `hasAttributeWithName` "foreign" -> varName w_fptr
+    Pointer _ _ ty | isVoidTy ty -> varName w_ptr
+    Pointer pt _ ty
+      | isIfaceTy ty -> refMarshallType mInfo{forRef=False}
+	       		                (Pointer Ref True (getIfaceTy ty))
+      | otherwise ->
+        case pt of
+	  Ptr     -> varName w_ptr
+          Ref  
+	     | optNoDerefRefs -> funApp w_ref [ allocPointerTo ty, refMarshallType mInfo ty ]
+	     | otherwise      -> refMarshallType mInfo ty
+	  Unique  -> funApp w_unique   [ allocPointerTo ty, refMarshallType mInfo ty ]
+    Void -> varName w_addr
+    Bool -> varName w_bool
+    CUnion i _ _ -> 
+        let 
+	  nm  = mkMarshaller marshallRefPrefix t
+	  sw  = 
+	    case (getSwitchIsAttribute (idAttributes i)) of
+	      Just e | notNull fs -> 
+		 let v = head fs in var ("write_tag_" ++ v)
+		where
+		 fs = findFreeVars e
+	      _ -> var ("where_do_I_put_the_tag")
+	in
+        funApply (varName nm) [sw]
+    Iface{} -> refMarshallType mInfo (Pointer Ref True t)
+    Name _ _ _ _ _ (Just ti) | not (is_pointed ti) -> varName (ref_marshaller ti)
+    Name _ _ _ _ (Just ty@Enum{}) _ -> refMarshallType mInfo ty
+    Name _ _ _ _ (Just ty@(Name{})) _ -> refMarshallType mInfo ty
+    Enum{} -> varName w_enum32
+    Name nm _ mod _ (Just ty) _ 
+       | not is_cons_type -> refMarshallType mInfo ty
+       | not (forStruct mInfo) && isNonEncUnionTy (removeNames ty) -> funApply w_ty w_args
+       | otherwise        -> 
+           if isFinalisedType True ty then
+	      funApply w_ty [ w_iptr_arg ]
+	   else
+	      w_ty
+      where
+       is_cons_type = isConstructedTy (nukeNames ty)
+       w_ty = varName (prefix marshallRefPrefix (mkQVarName mod nm))
+      
+       w_args
+	 | isFinalisedType True ty = [ w_iptr_arg, write_tag ]
+	 | otherwise		   = [ write_tag ]
+
+       write_tag = lam [wildPat] (ret unit)
+
+    Integer LongLong isSigned
+      | optLongLongIsInteger -> varName (w_integer isSigned)
+    _    -> varName (mkMarshaller marshallRefPrefix t)
+
+  where
+   w_bool      = libImport bool
+   w_string    = libImport stringName
+   w_blist     = libImport blist
+   w_list      = libImport list
+   w_bstring   = libImport bstring
+   w_ptr       = libImport ptrName
+   w_fptr      = libImport fptr
+   w_ref       = libImport ref
+   w_unique    = libImport unique
+   w_addr      = libImport ptrName
+   w_sequence  = libImport "Sequence"
+
+   w_safearray
+     | forStruct mInfo = prefix marshallRefPrefix sAFEARRAY
+     | otherwise       = prefix marshallRefPrefix (mkQVarName autoLib safearray)
+
+   w_integer isSigned
+     | isSigned  = libImport integer
+     | otherwise = libImport ('U':integer)
+
+   w_enum32   = libImport enum32
+
+   w_iptr     = prefix marshallRefPrefix iUnknown
+
+   w_iptr_arg
+     | forStruct mInfo = var "addRefMe__"
+     | otherwise       = lit (BooleanLit (forProxy mInfo))
+
+   w_wstring 
+     | optNoWideStrings = wStringImport wstring2
+     | otherwise        = wStringImport wstring
+
+   libImport nm = prefix marshallRefPrefix (mkQVarName hdirectLib nm)
+   wStringImport nm = prefix marshallRefPrefix (mkQVarName wStringLib nm)
+
+
+refUnmarshallType :: MarshallInfo -> Type -> Haskell.Expr
+refUnmarshallType mInfo t = 
+  case t of
+    Array (Char _) [e] -> funApp r_bstring  [ coreToHaskellExpr e ]
+       -- this is the identity unmarshallers under the assumption
+       -- that the array ref. type is used in conjunction with
+       -- a 'dependent' attribute (size_is() et. al). This may
+       -- not always be the case, so this is may cause breakage.
+       --
+       -- 3/99: Changed to instead do something a bit saner, but
+       --       tell the user of the problem.
+    Array ty []	  
+       -> trace ("warning: unmarshalling incomplete array type decl, " ++ showCore (ppType t) ++ 
+                 " , don't know how big.\n Assuming of length 1. " ) $
+          funApp r_blist
+	     [ szType t
+	     , lit (iLit (1::Int))
+	     , refUnmarshallType mInfo{forRef=False} ty
+	     ]
+    Array ty [e] -> 
+      funApp r_blist
+             [ szType ty
+	     , coreToHaskellExpr e
+	     , refUnmarshallType mInfo{forRef=False} ty
+	     ]
+
+    String _ isUnique _ 
+      | isUnique  -> funApp readMaybe [ varName r_string ]
+      | otherwise -> varName r_string
+
+    WString isUnique _ 
+      | isUnique  -> funApp readMaybe [ varName r_wstring ]
+      | otherwise -> varName  r_wstring
+    SafeArray _ -> r_safearray
+
+    Sequence ty mbSz mbTerm -> 
+    		    funApp r_sequence [ refUnmarshallType mInfo{forRef=False} ty
+    				      , terminatorElt False mbTerm ty
+				      , szType ty
+				      , case mbSz of 
+				          Nothing -> nothing
+					  Just x  -> just (coreToHaskellExpr x)
+				      ]
+
+    Pointer Unique isExp ty
+      | forRef mInfo              && 
+        (optCom || optHaskellToC) &&
+	isExp 			  &&
+	isIfaceTy ty    -> funApp r_unique [ u_ip ]
+      where
+       (Iface nm mod _ attrs _ _) = getIfaceTy ty
+       u_ip 
+        | optHaskellToC  =
+		funApp (prefix unmarshallRefPrefix (mkQVarName mod nm))
+		       (if attrs `hasAttributeWithName` "finaliser" then
+		       	   [ lit (BooleanLit (not (forProxy mInfo))) ]
+			else
+			   [{-empty-}]
+		       )
+	| otherwise      = funApp u_iptr [ final_arg ]
+
+    Pointer _ _ (Iface nm mod _ attrs _ inh) ->
+       case inh of
+         [] | optCom     -> funApp r_iptr [ final_arg ]
+	    | optHaskellToC && attrs `hasAttributeWithName` "finaliser" ->
+		 		    funApply r_ip [ lit (BooleanLit (not (forProxy mInfo))) ]
+
+	    | otherwise	 -> r_ip
+	 (x:_) 
+	       | optCorba  -> varName (prefix unmarshallRefPrefix (fst x))
+	       | optCom    -> funApp r_iptr [ final_arg ]
+	       | optHaskellToC && attrs `hasAttributeWithName` "finaliser" ->
+		 		    funApply (varName (prefix unmarshallRefPrefix (fst x)))
+				    	     [ lit (BooleanLit (not (forProxy mInfo))) ]
+	       | otherwise -> varName (prefix unmarshallRefPrefix (fst x))
+      where
+       r_ip = varName (prefix unmarshallRefPrefix (mkQVarName mod nm))
+
+{-
+    Pointer Unique isExp ty
+      | forRef mInfo && 
+        optCom       &&
+	isIfaceTy ty    -> funApp r_unique [ funApp u_iptr [ final_arg ]]
+-}
+
+    Pointer pt _ (Name _ _ _ _ _ (Just ti))
+      | pt /= Ptr && is_pointed ti -> 
+	  case pt of
+	    Unique -> funApp readMaybe [ e ]
+	    _      -> e
+         where
+	  e 
+           | finalised ti = funApply (varName (ref_unmarshaller ti)) [ final_arg ]
+	   | otherwise    = varName (ref_unmarshaller ti)
+
+    Pointer Ref _ t1@(Name _ _ _ _ (Just ty) _)
+      | isConstructedTy (nukeNames ty) -> 
+	      if isFinalisedType False ty then
+	         funApply r_ty [ final_arg ]
+	      else
+	         r_ty
+          where
+	   r_ty = varName (mkMarshaller unmarshallRefPrefix t1)
+
+    Pointer Ptr _ (Name _ _ _ (Just as) _ _)
+      | as `hasAttributeWithName` "foreign" -> varName r_fptr
+    Pointer _ _ Void    -> varName r_ptr
+    Pointer pt _ ty
+      | isIfaceTy t -> refUnmarshallType mInfo (Pointer Ref True (getIfaceTy t))
+      | otherwise   -> 
+      case pt of
+	Ptr     -> varName r_ptr -- we stop unmarshalling once we encounter a [ptr] pointer.
+        Ref     -> 
+	    -- I don't understand the motivation for ignoring the [ref] here any longer!
+	    -- Conseq, -fopt-no-deref-refs can be used to turn off this 'feature' until
+	    -- the ramifications of doing it one way vs. the other can be more carefully
+	    -- assessed (same option applies to ref-marshalling of [ref]s.)
+	   if (forRef mInfo || not (isPointerTy ty)) && not optNoDerefRefs then 
+	      refUnmarshallType mInfo ty
+	   else
+	          funApp r_ref     [ refUnmarshallType mInfo{forRef=False} ty ]
+	Unique -> funApp r_unique  [ refUnmarshallType mInfo{forRef=False} ty ]
+    Void  -> varName r_addr
+    Bool  -> varName r_bool
+    CUnion i _ _ -> 
+        let 
+	  nm  = mkMarshaller unmarshallRefPrefix t
+	  sw  = 
+	    case (getSwitchIsAttribute (idAttributes i)) of
+	      Just e | notNull fs -> 
+	        let v = head fs in var ("read_tag_" ++ v)
+	       where
+	         fs = findFreeVars e
+		
+	      _            -> var ("where_do_I_get_the_tag_from")
+	in
+        funApply (varName nm) [sw]
+    Iface{} -> refUnmarshallType mInfo (Pointer Ref True t)
+    Name _ _ _ _ _ (Just ti) {-  not (is_pointed ti) -} -> 
+		if finalised ti then
+		  funApply (varName (ref_unmarshaller ti)) [ final_arg ]
+		else
+		   varName (ref_unmarshaller ti)
+    Name _ _ _ _ (Just ty@Enum{}) _ -> refUnmarshallType mInfo ty
+    Name _ _ _ _ (Just ty@(Name{})) _ -> refUnmarshallType mInfo ty
+    Enum{} -> varName r_enum32
+    Integer LongLong isSigned
+      | optLongLongIsInteger -> varName (r_integer isSigned)
+    Name nm _ mod mb_attrs (Just ty) _
+      | not (forRef mInfo) && isNonEncUnionTy (removeNames ty) ->
+         funApply (varName (mkMarshaller unmarshallRefPrefix t))
+		  r_args
+      | not is_cons_type -> refUnmarshallType mInfo ty
+      | is_cons_type     -> 
+           if isFinalisedType False ty then
+	      funApply r_ty [ final_arg ]
+	   else
+	      r_ty
+       where
+          
+
+          r_ty = varName (prefix unmarshallRefPrefix (mkQVarName mod nm))
+
+          is_cons_type = isConstructedTy (nukeNames ty)
+	  attrs    = 
+		fromMaybe [] mb_attrs ++
+		idAttributes (getTyTag (getNonEncUnionTy ty))
+
+	  r_args
+	   | isFinalisedType False ty = [ final_arg, read_tag ]
+	   | otherwise		      = [ read_tag ]
+
+          read_tag = 
+               case getSwitchIsAttribute attrs of
+                 Nothing -> ret (lit (iLit ((-1)::Int)))
+                 Just v  -> ret (coreToHaskellExpr v)
+    _     -> varName (mkMarshaller unmarshallRefPrefix t)
+  where
+   r_bool   = libImport bool
+   r_string = libImport stringName
+   r_blist  = libImport blist
+   r_bstring = libImport bstring
+   r_ptr    = libImport ptrName
+   r_fptr   = libImport fptr
+   r_ref    = libImport ref
+   r_unique = libImport unique
+   r_addr   = libImport ptrName
+   r_sequence  = libImport "Sequence"
+
+   r_safearray 
+     | forStruct mInfo = funApply (varName (prefix unmarshallRefPrefix sAFEARRAY))  [ lit (BooleanLit False) ]
+     | otherwise       = funApply (varName (prefix unmarshallRefPrefix (mkQVarName autoLib safearray)))
+     				  [ lit (BooleanLit (not (forProxy mInfo))) ]
+
+   r_integer isSigned
+     | isSigned  = libImport integer
+     | otherwise = libImport ('U':integer)
+
+   r_enum32 = libImport enum32
+
+   r_iptr        = prefix unmarshallRefPrefix iUnknown
+
+   final_arg
+     | forStruct mInfo = var "finaliseMe__"
+     | otherwise       = lit (BooleanLit (forProxy mInfo))
+
+   u_iptr        = prefix unmarshallPrefix iUnknown
+   r_wstring
+    | optNoWideStrings = wStringImport wstring
+    | otherwise        = wStringImport wstring
+
+   libImport nm     = prefix unmarshallRefPrefix (mkQVarName hdirectLib nm)
+   wStringImport nm = prefix unmarshallRefPrefix (mkQVarName wStringLib nm)
+
+
+\end{code}
+
+\begin{code}
+coreToHaskellExpr :: Expr -> Haskell.Expr
+coreToHaskellExpr e =
+ case e of
+   Binary bop e1 e2 -> binOp bop (coreToHaskellExpr e1) 
+   				 (coreToHaskellExpr e2)
+   Cond e1 e2 e3 ->
+     hCase (coreToHaskellExpr e1) 
+	[ alt (conPat (mkQConName prelude "True") [])  (coreToHaskellExpr e2)
+	, alt (conPat (mkQConName prelude "False") []) (coreToHaskellExpr e3)
+	]
+   Unary  uop e1 -> unaryOp uop (coreToHaskellExpr e1)
+   Var nm        -> var (mkHaskellVarName nm)
+   Lit l         -> lit l
+   Cast _ e1     -> coreToHaskellExpr e1
+--   Sizeof t      -> funApp (mkQualName Nothing sizeOfName) [szType t]
+   Sizeof t      -> varName (mkMarshaller sizeofPrefix t)
+\end{code}
+
+The library functions does not rely on overloading 
+of their numeric arguments. Instead, the generated code
+will insert coercions that map arguments to the expected
+types.
+
+\begin{code}
+coerceTy :: Type -> Type -> Haskell.Expr -> Haskell.Expr
+coerceTy from_ty to_ty e 
+ | to_ty == from_ty = e
+ | otherwise = Haskell.WithTy
+                   (funApp (mkQualName prelude (mkHaskellVarName "fromIntegral"))
+                          [ e ])
+	           (toHaskellBaseTy False to_ty)
+\end{code}
+
+Allocation and a couple of other functions in the support library
+uses Ints as arguments; make sure that arguments passed to them
+are properly coerced.
+
+\begin{code}
+coerceToInt :: Expr -> Haskell.Expr
+coerceToInt e = 
+  case e of
+    Lit IntegerLit{} -> c_expr
+    _ -> funApp fromIntegralName [c_expr]
+ where
+  c_expr = coreToHaskellExpr e
+\end{code}
+
+
+\begin{code}
+szType :: Type -> Haskell.Expr
+szType (Array t [e]) = binOp Mul (szType t) (coerceToInt e)
+szType t 
+  | isEnum        = varName enumSize 
+  | isIntegerTy t = varName (prefix sizeofPrefix (mkQualName hdirectLib "Int64"))
+  | otherwise = 
+      case t of
+        Name _ _ _ _ _ (Just ti) -> varName (prim_size ti)
+        _                        -> varName (mkMarshaller sizeofPrefix t)
+--        _                        -> varName (mkMarshaller sizeOfName t)
+ where
+  isEnum = isJust enumRes
+ 
+  enumRes = checkIfEnum t
+
+  (Just enumSize) = enumRes
+
+  checkIfEnum Enum{} = Just (mkQVarName hdirectLib "sizeofInt32")
+  checkIfEnum (Name _ _ _ _ (Just ty) _) = checkIfEnum ty
+  checkIfEnum _	                         = Nothing
+
+\end{code}
+
+\begin{code}
+allocPointerTo :: Type -> Haskell.Expr
+allocPointerTo ty  =
+  case ty of
+    Name _ _ _ _ _ (Just ti) | isJust (alloc_type ti) -> varName (fromJust (alloc_type ti))
+    Pointer _ _ (Name _ _ _ _ _ (Just ti)) | isJust (alloc_type ti) -> varName (fromJust (alloc_type ti))
+    _ -> funApp allocBytes [funApp fromIntegralName [szType ty']]
+ where
+  ty' = 
+    case ty of
+      Void	       -> Pointer Ptr True Void
+      Pointer _ _ Void -> ty
+      _		       -> removePtr ty
+\end{code}
+
+Generating a *call* to free a marshalled representation
+of type t (if needed.) The modules that deal with the generation
+of marshalling code for user-defined types take care of generating
+freeing/release functions for such types.
+
+\begin{code}
+freeType :: Type -> Haskell.Expr
+freeType ty =
+ case mbFreeType ty of
+   Nothing -> varName trivialFree
+   Just e  -> e
+
+mbFreeType :: Type -> Maybe Haskell.Expr
+mbFreeType ty =
+ case ty of
+    {- Pointer to structs decorated with [free(foo)] are freed using 'foo'. -}
+  Pointer _ _ (Name _ _ _ _ (Just (Struct tg _ _)) _) 
+    | (idAttributes tg) `hasAttributeWithName` "free" ->
+      case findAttribute "free" attrs of
+        Just (Attribute _ [ParamLit (StringLit freeR)]) -> Just (var freeR)
+	_						-> mbFreeType' True ty
+    | attrs `hasAttributeWithName` "free_method" ->
+ 	-- what an ad-hac hock!
+      case findAttribute "free_method" attrs of
+        Just (Attribute _ [ParamLit (StringLit freeR)]) -> 
+				Just (lam [varPat (var "x")] $
+				          funApply (var freeR) [var "x", var "iptr"])
+	_ -> mbFreeType' True ty
+     where
+      attrs = idAttributes tg
+
+  _ -> mbFreeType' True ty
+
+mbFreeType' :: Bool -> Type -> Maybe Haskell.Expr
+mbFreeType' isTop ty = 
+ case ty of
+  Pointer _ _ (Name _ _ _ _ _ (Just ti)) | is_pointed ti &&
+  				         finalised ti -> Nothing
+  Pointer _ _ Void    -> Nothing
+  Pointer _ _ Iface{} -> Nothing
+   {- The Haskell representation of a unique pointer is as a
+      Maybe-valued `thing', where the `thing' is the unmarshalled
+      representation of the pointer type. Clearly, the thing we're
+      pointing to will have to be freed, but it in turn may have
+      to free up some of its components first.
+   -}
+  Pointer Unique _ t
+     | isIfaceTy t       -> Nothing
+     | otherwise	 ->
+       case mbFreeType' False t of
+	  Just v  -> Just (funApp (prefix freePrefix (mkQVarName hdirectLib unique)) [ v ])
+          Nothing | isTop     -> Just (varName free)
+	  	  | otherwise -> Nothing
+
+   -- no marshalling was done on this in the first place, so nothing to free.
+  Pointer Ptr _ _ -> Nothing
+   -- the type embedded within the reference may have to be freed ...
+  Pointer Ref _ t ->
+  	case (mbFreeType' False t) of
+	  Just v  -> Just (funApp (prefix freePrefix (mkQVarName hdirectLib ref)) [v])
+          Nothing | isTop     -> Just (varName free) -- just free the toplevel pointer.
+	          | otherwise -> Nothing
+
+   -- the array may consist of elements that may need to be freed
+   -- individually, so we better check by looking at the element type..
+   -- [in many cases element-wise freeing isn't right, since the
+   --  array was block allocated initially, so let's not do this for
+   --  now -- assume block allocation.]
+  Array aty _		
+   | needsFreeing aty -> Just (varName free)
+   | isTop	      -> Just (varName free)
+   | otherwise	      -> Nothing
+
+   -- the String/sequence type contains a null-terminated sequence of unpointed objects,
+   -- so no need to do per-elt release/free.
+  String{}          -> Just (varName (prefix freePrefix (mkQVarName hdirectLib stringName)))
+  WString{}         -> Just (varName (prefix freePrefix (mkQVarName wStringLib wstring)))
+  Sequence{}        -> Just (varName (prefix freePrefix (mkQVarName hdirectLib "Sequence")))
+   -- nothing to free for marshalled enums (not in an external heap, anyway.)
+  Enum{} -> Nothing
+   -- Note: a toplevel struct is currently not possible, so we don't
+   -- actually free the structure itself, but assume that whoever has a pointer to
+   -- this struct value does. 
+   -- 
+   -- Notice that since we have complete information about what the struct
+   -- contains, we could have generated the calls to free up the fields
+   -- that needs to be explicitly release here. However, the cost of doing
+   -- this inline hardly seems worth it. (Rely on the Haskell compiler
+   -- to do the inlining instead.)
+   -- 
+  Struct tg fields _ 
+	  | any (needsFreeing.fieldType) fields -> Just (varName (prefix freePrefix (mkVarName (idName tg))))
+	  | otherwise -> Nothing
+
+   -- See above comment for structs.
+   -- The tag type isn't pointed (I hope!), so we only need to worry about
+   -- freeing the embedded value.
+  Union i _ _ _ switches 
+   | swNeedsFreeing switches -> Just (varName (prefix freePrefix (mkVarName (idName i))))
+   | otherwise -> Nothing
+
+  UnionNon i switches 
+   | swNeedsFreeing switches ->  Just (varName (prefix freePrefix (mkVarName (idName i))))
+   | otherwise -> Nothing
+
+  CUnion i fields _
+   | any (needsFreeing.fieldType) fields ->  Just (varName (prefix freePrefix (mkVarName (idName i))))
+   | otherwise -> Nothing
+
+  Name nm _ mod mb_attrs mb_ty mb_ti
+    | don'tFree mb_attrs || 
+      (isJust mb_ti && 
+        finalised (fromJust mb_ti)) -> Nothing
+    | isJust mb_ti && isJust (free_type (fromJust mb_ti)) -> fmap varName (free_type (fromJust mb_ti))
+    | otherwise ->
+     case mb_ty of
+       Nothing -> Nothing -- Hmm..
+       Just t 
+	     -- want the name of the constructed type rather than its tag...if it needs to be released.
+         | isConstructedTy (nukeNames t) -> 
+		case mbFreeType' False t of
+		  Just _ | isTop -> Just (funApply (varName (prefix freePrefix (mkQConName mod (mkHaskellTyConName nm))))
+					           args)
+		  _ -> Nothing
+         | otherwise ->
+           case mbFreeType' False t of
+	     Just aty | not (don'tFree mb_attrs) -> Just aty
+	     	      | otherwise		 -> Nothing
+	     Nothing -> Nothing
+            where
+             args
+              | isNonEncUnionTy t = [read_tag]
+              | otherwise         = []
+
+             attrs    = fromMaybe [] mb_attrs
+
+             read_tag = 
+               case getSwitchIsAttribute attrs of
+                 Nothing -> lit (iLit ((-1)::Int))
+                 Just v  -> coreToHaskellExpr v
+       
+  _ -> Nothing
+
+ where
+  don'tFree Nothing   = False
+  don'tFree (Just ls) = ls `hasAttributeWithName` "nofree"
+
+
+-- poorly named, but `needsFreeing' returns True
+-- if a marshalled representation of an IDL type
+-- has to be explicitly released (=> it was allocated
+-- externally.)
+needsFreeing :: Type -> Bool
+needsFreeing t = go True t
+ where
+  go toplevel ty = 
+   case ty of
+    Pointer _ _ (Name _ _ _ _ _ (Just ti)) | is_pointed ti -> not (finalised ti)
+    Pointer Unique _ pty -> needsFreeing pty
+    Pointer Ref _ pty -> needsFreeing pty
+    Pointer Ptr _ _ -> False
+    Array _ _ -> True
+    String{}  -> toplevel
+    WString{} -> toplevel
+    Name _ _ _ _ _ (Just ti) -> not (finalised ti)
+    Name _ _ _ _ mb_ty _ -> mapFromMb False needsFreeing mb_ty
+    Struct _ fields _ -> any ((go False).fieldType) fields
+    Union _ _ _ _ switches -> any sw_go switches
+    UnionNon _ switches    -> any sw_go switches
+    CUnion _ fields _ -> any ((go False).fieldType) fields
+    _ -> False -- basic numeric/char types + void & enum.
+
+  sw_go (SwitchEmpty _) = False
+  sw_go s	        = go False (switchType s)
+
+swNeedsFreeing :: [Switch] -> Bool
+swNeedsFreeing [] = False
+swNeedsFreeing (SwitchEmpty _ : xs) = swNeedsFreeing xs
+swNeedsFreeing (s : xs) = (needsFreeing (switchType s)) || swNeedsFreeing xs
+\end{code}
+ src/MarshallUnion.lhs view
@@ -0,0 +1,307 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 9th 2003  08:00  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Generating code for the various types of IDL unions.
+
+\begin{code}
+module MarshallUnion ( marshallUnion ) where
+
+import BasicTypes ( Name, QualName, qName, BinaryOp(..) )
+import AbstractH  ( HDecl )
+import AbsHUtils
+import Literal ( iLit )
+import CgMonad
+
+import CoreIDL
+import MarshallMonad
+import MarshallType
+import MarshallCore   ( toHaskellBaseTy )
+import CoreUtils
+import LibUtils
+import Utils	      ( trace, traceIf )
+import Char	      ( ord )
+import Opts	      ( optCom )
+
+\end{code}
+
+<sect> Encapsulated unions
+<label id="sec:encap-union">
+<p>
+
+\begin{code}
+marshallUnion :: Name 
+	      -> Either (Id,Type) Type
+	      -> Bool
+	      -> [Switch]
+	      -> Maybe Int
+	      -> CgM HDecl
+marshallUnion tdef_name tag_info isCUnion switches_raw mb_pack
+ | null switches = trace ("Empty union: "++ tdef_name) $ return emptyDecl
+ | otherwise     = do 
+    ds <- mapM exportDecl decl_list
+    return (andDecls ds)
+   where
+    decl_list =
+     [ ( m_name, m_tysig `andDecl`  m_def)
+     , ( u_name, u_tysig `andDecl`  u_def)
+     , ( w_name, w_tysig `andDecl`  w_def)
+     , ( r_name, r_tysig `andDecl`  r_def)
+     , ( s_name, s_tysig `andDecl`  s_def)
+     , ( f_name, f_tysig `andDecl`  f_def)
+     ]
+
+    switches = moveEmptiesBackwards [] switches_raw 
+      where
+       moveEmptiesBackwards acc [] = acc
+       moveEmptiesBackwards acc (s@(SwitchEmpty _):ss) = moveEmptiesBackwards (s:acc) ss
+       moveEmptiesBackwards acc (s:ss) = s: moveEmptiesBackwards acc ss
+
+    name      = mkConName tdef_name
+
+    isEncapsulated =
+      case tag_info of
+        Left  _ -> True
+	Right _ -> False
+    
+    (un_tag, tag_ty) =
+      case tag_info of
+        Left (tg,t) -> (tg,t)
+	Right t     -> ( error "marshallUnion: not supposed to touch - unencapsulated unions don't have embedded tags"
+		       , t
+		       )
+
+    un_tag_ty = UnionNon un_tag switches
+
+    expanded_ty_fields
+      | isEncapsulated = 
+         [ Field un_tag    tag_ty    tag_ty Nothing Nothing -- the tags are ignored, so it
+	 , Field un_tag un_tag_ty un_tag_ty Nothing Nothing -- doesn't matter what's used.
+	 ]
+      | otherwise      =
+         [ Field un_tag un_tag_ty un_tag_ty Nothing Nothing -- doesn't matter what's used.
+	 ]
+
+    ( (st_size,_), 
+      (_: ~(un_off:_))) = computeStructSizeOffsets mb_pack expanded_ty_fields
+
+    v		 = var "v"
+    write_tag    = var "write_tag"
+    read_tag     = var "read_tag"
+    tag          = var "tag"
+    ptr          = var "ptr"
+    ptr_cast     = castPtr ptr
+
+    addRef_fields = isFinalisedType True  (Union undefined undefined undefined undefined switches)
+    final_fields  = isFinalisedType False (Union undefined undefined undefined undefined switches)
+
+    union_ptr 
+      | isEncapsulated = addPtr ptr (lit (iLit un_off))
+      | otherwise      = ptr_cast
+
+    t_ty         = tyConst tdef_name
+    b_ty         = tyConst tdef_name
+    b_tag_ty     = toHaskellBaseTy False tag_ty
+
+    m_name   = qName (prefix marshallPrefix name)
+    m_tysig  = typeSig m_name (funTy t_ty (io (tuple [b_ty, b_tag_ty])))
+    m_def    = funDef m_name [] m_rhs
+    m_rhs    = funApp marshUnion [stringLit m_name]
+
+    u_name   = qName (prefix unmarshallPrefix name)
+    u_tysig  = typeSig u_name (funTys [b_ty, b_tag_ty] (io t_ty))
+    u_def    = funDef u_name [] u_rhs
+    u_rhs    = funApp unmarshUnion [stringLit u_name]
+
+    w_name   = qName (prefix marshallRefPrefix name)
+    w_tysig 
+     | isEncapsulated = typeSig w_name (funTys (mk_w_type [tyPtr b_ty, t_ty]) io_unit)
+     | otherwise      = typeSig w_name (funTys (mk_w_type [funTy b_tag_ty io_unit, tyPtr b_ty, t_ty]) io_unit)
+
+    mk_w_type
+     | optCom && addRef_fields = (tyBool:)
+     | otherwise	       = id
+
+    w_def    
+     | isEncapsulated = funDef w_name (mk_w_pats [varPat ptr, varPat v]) w_rhs
+     | otherwise      = funDef w_name (mk_w_pats [varPat write_tag, varPat ptr, varPat v]) w_rhs
+     
+    mk_w_pats
+     | optCom && addRef_fields = ((patVar "addRefMe__") :)
+     | otherwise	       = id
+
+    w_rhs    = hCase v w_alts
+    w_alts   = concatMap mk_w_alt switches
+       
+    mk_w_alt (Switch i labs ty _) =
+	let 
+	 elt_nm = idName i
+	 elt    = var elt_nm
+	 the_tag = 
+	   case filter (/=Default) labs of
+	     (Case e : _ ) -> coreToHaskellExpr e
+	     []         -> 
+		traceIf (not isCUnion && null labs)
+				   ("Warning: union member `" ++ elt_nm ++ "' of typedef `" ++ 
+				     tdef_name ++ "' doesn't have an associated tag") $
+	        intLit ((-1)::Int) -- default case, not right.
+  
+             _ -> error "MarshallUnion.marshallUnion.mk_w_alt: unexpected, something's badly wrong"
+	in
+	[ alt (conPat (mkConName (mkHaskellTyConName elt_nm)) [varPat elt]) $
+	     bind_ (if isEncapsulated then
+	              funApply (refMarshallType stubMarshallInfo tag_ty) [ptr_cast, the_tag]
+		    else
+		       funApply write_tag [the_tag]) $
+	     -- assume that enough space have been allocated for us to fill
+	     -- in the tag's value. I'm not sure this is always the case!
+	     -- For instance, if the tag's value is a string, we will
+	     -- just have allocated space for a char* pointer, not the
+	     -- string (i.e., size is currently considered a property of
+	     -- the type and not any different from values of that type.)
+	     --
+	     -- However, as a first approximation, this will have to do..
+	     -- 
+	     -- ToDo: revisit this issue (hopefully before users are bitten by this!)
+	     -- 
+	    let un_ptr
+	         | isEncapsulated = addPtr ptr (lit (iLit un_off))
+		 | otherwise	  = ptr_cast
+	    in
+	    funApply (refMarshallType structMarshallInfo ty) [un_ptr, elt]
+       ]
+
+     -- not much we can do but match the anonymous constructor, i.e.,
+     --		Foo -> return ()
+    mk_w_alt (SwitchEmpty mb_labs) = 
+       case mb_labs of
+         Nothing -> [alt (conPat (mkConName (tdef_name ++ "_Anon")) []) (ret unit)]
+	 Just ls -> map toAlt ls
+	  where
+	   toAlt (Default, tg_nm) = 
+	        alt (conPat (mkConName (tdef_name ++ tg_nm)) [])
+		    (ret unit)
+	   toAlt (Case e, tg_nm)  =
+	        alt (conPat (mkConName (tdef_name ++ tg_nm)) [])
+		    (bind_
+		      (funApply (refMarshallType stubMarshallInfo tag_ty) [ptr, coreToHaskellExpr e])
+		      (ret unit) -- why do I need this?
+		      )
+
+    r_name   = qName (prefix unmarshallRefPrefix name)
+    r_tysig  
+      | isEncapsulated = typeSig r_name (funTys (mk_r_type [tyPtr b_ty]) (io t_ty))
+      | otherwise      = typeSig r_name (funTys (mk_r_type [io b_tag_ty, tyPtr b_ty]) (io t_ty))
+
+    mk_r_type
+      | final_fields   = (tyBool:)
+      | otherwise      = id
+
+    r_def    
+      | isEncapsulated = funDef r_name (mk_r_pats [varPat ptr]) r_rhs
+      | otherwise      = funDef r_name (mk_r_pats [varPat read_tag, varPat ptr]) r_rhs
+    
+    mk_r_pats
+      | final_fields   = (patVar "finaliseMe__":)
+      | otherwise      = id
+
+    r_rhs   = 
+      mkAlts 
+          r_name
+          (if isEncapsulated then
+	     funApply (refUnmarshallType stubMarshallInfo tag_ty) [ptr_cast]
+	   else
+	     read_tag)
+	  tag
+	  (concat $ map mkGuard switches)
+
+    mkAlts nm _ _ [] = 
+        trace ("Warning: `" ++ nm ++"': no tag info to interpret. (generating bogus stub - please fix it or the original IDL spec.)") $
+	funApp prelError [stringLit (nm ++": I am the " ++ thing)]
+       where
+        sum_nm = foldr (\ x acc -> ord x + acc) 0 nm
+
+        thing
+	 | odd sum_nm = "walrus."
+	 | otherwise  = "eggman."
+	 
+    mkAlts _ rtag tg alts = bind rtag tg (hCase tag alts)
+
+    mkGuard (Switch i labs ty _) = map mkSwitch labs
+     where
+      mkSwitch Default  = 
+	 alt wildPat
+	     (bind (funApply (refUnmarshallType structMarshallInfo ty) [union_ptr]) v $
+	      ret  (dataCon (mkConName (mkHaskellTyConName (idName i))) [v]))
+
+      mkSwitch (Case e) = 
+	let h_expr = coreToHaskellExpr e in
+	case (exprToPat h_expr) of
+	  Just simple_pat -> 
+		alt simple_pat
+		    (bind (funApply (refUnmarshallType structMarshallInfo ty) [union_ptr]) v $
+		     ret  (dataCon (mkConName (mkHaskellTyConName (idName i))) [v]))
+	   -- either totally bogus or a non-simple expression
+	   -- Emit a 
+	  Nothing -> 
+		genAlt (patVar "x") (binOp Eq (var "x") h_expr)
+		    (bind (funApply (refUnmarshallType structMarshallInfo ty) [union_ptr]) v $
+		     ret  (dataCon (mkConName (mkHaskellTyConName (idName i))) [v]))
+		       
+		    
+    mkGuard (SwitchEmpty mb_labs) =
+       case mb_labs of
+         Nothing -> [alt wildPat $
+	             ret (dataCon (mkConName (tdef_name ++ "_Anon")) [])]
+	 Just ls ->
+	   map (\ x -> alt wildPat (ret (dataCon (mkConName (tdef_name ++ x)) [])))
+	       ls_nm
+	   where
+	    ls_nm = map snd ls
+
+    s_name   = qName (prefix sizeofPrefix name)
+    s_tysig  = typeSig s_name tyWord32
+    s_def    = funDef s_name [] s_rhs
+    s_rhs    = intLit st_size
+
+     -- the auto-generated free routine releases a packed rep.
+     -- of the union - perhaps also generate one for the unpacked
+     -- version?
+
+    f_name   = qName (prefix freePrefix name)
+    f_tysig  
+       | isEncapsulated = typeSig f_name (funTy (tyPtr b_ty) (io_unit))
+       | otherwise      = typeSig f_name (funTys [b_tag_ty, tyPtr b_ty] (io_unit))
+
+    f_def    
+       | isEncapsulated = funDef f_name [varPat ptr] f_rhs
+       | otherwise      = funDef f_name [varPat read_tag, varPat ptr] f_rhs
+    f_rhs    = 
+       mkAlts
+          f_name
+          (if isEncapsulated then
+               funApply (refUnmarshallType stubMarshallInfo tag_ty) [ptr]
+	   else
+	       ret read_tag)
+	  tag
+	  (concat $ map freeGuard switches)
+     where
+       freeGuard (Switch _ labs _ orig_ty) = map mkSwitch labs
+        where
+	 free_it
+	  | not (needsFreeing orig_ty) = ret unit
+	  | otherwise                  = funApply (freeType orig_ty) [union_ptr]
+
+         mkSwitch Default  = alt wildPat free_it
+         mkSwitch (Case e) = 
+	    let h_expr = coreToHaskellExpr e in
+	    case (exprToPat h_expr) of
+	      Just pat -> alt pat free_it
+	      Nothing  -> genAlt (patVar "x") (binOp Eq (var "x") h_expr) free_it
+
+       freeGuard (SwitchEmpty _) = [alt wildPat (ret unit) ]
+
+\end{code}
+ src/MarshallUtils.lhs view
@@ -0,0 +1,249 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Jun. 9th 2003  16:33  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+\begin{code}
+module MarshallUtils 
+	(
+	  mkHVar
+	, adjustField
+	
+	, prefixHTy
+	, appHTy
+	
+	, infoHeader
+	
+	, helpStringComment
+	
+	, toHaskellIfaceTy
+
+	, findParamDependents
+	, findFieldDependents
+	, removeDependees
+	, removeDependents
+	, removeDependers
+	) where
+
+import BasicTypes
+import CoreUtils
+import CoreIDL
+import Attribute
+import qualified AbstractH as Haskell
+import AbsHUtils   ( var, prefix, prefixApp, mkVarName, comment,
+		     andDecl, andDecls, emptyDecl, tyQCon, tyVar, mkTyCon,
+		     tyQConst, ctxtTyApp, ctxtClass
+		   )
+import PpCore      ( ppDecl, showCore, setDebug )
+import PpAbstractH ( ppType, showAbstractH )
+
+import LibUtils
+
+import Literal
+import List  ( intersperse )
+import Utils ( notNull )
+import Opts  ( optShowIDLInComments, optIgnoreHelpstring,
+	       optCorba, optHaskellToC, optJNI, optSubtypedInterfacePointers )
+
+\end{code}
+
+\begin{code}
+mkHVar :: Id -> Haskell.Expr
+mkHVar i = var (mkHaskellVarName (idName i))
+\end{code}
+
+Fields and parameters with pointer types that are represented
+as lists in Haskell land, are turned into raw([ptr]) pointers
+prior to marshalling. Why? Because the marshalling of these pointers
+has already been performed by the dependency marshalling. (Since
+[ptr] marshalling is the identity operation at the moment, we
+could equally well remove the dependent fields/params from the
+marshalling lists.)
+
+\begin{code}
+adjustField :: Bool -> [(Id,[Dependent])] -> Field -> Maybe Field
+adjustField forMarshalling dep_list f
+--  isSwitchDependee dep_list (fieldId f) = Nothing
+ | isDepender dep_list i && not (isArrayTy ty)
+ = 
+    if (forMarshalling && not (isIfaceTy ty)) || isSwitchDepender dep_list i then
+       Just (f{fieldType=mkPtrPointer ty})
+    else
+       Just (f{fieldType=Pointer Ptr True Void})
+ | otherwise
+ = if not forMarshalling && isArrayTy ty && isDepender dep_list i then
+      Just (f{fieldType=Pointer Ptr True Void})
+   else
+      Just f
+ where
+  i  = fieldId f
+  ty = fieldType f
+
+\end{code}
+
+\begin{code}
+prefixHTy :: String -> Haskell.Type -> QualName
+prefixHTy pre ty = 
+  case ty of
+    Haskell.TyVar _ tv  -> prefix pre tv
+    Haskell.TyCon tc    -> prefix pre tc
+    Haskell.TyApply f _ -> prefixHTy pre f
+    Haskell.TyList _    -> mkVarName (pre ++ list)
+    _ -> error ("prefixHTy: unexpected type" ++ showAbstractH (ppType ty))
+
+appHTy :: String -> Haskell.Type -> QualName
+appHTy pre ty = 
+  case ty of
+    Haskell.TyVar _ tv  -> prefixApp pre tv
+    Haskell.TyCon tc    -> prefixApp pre tc
+    Haskell.TyApply f _ -> appHTy pre f
+    Haskell.TyList _    -> mkVarName (pre ++ list)
+    _ -> error ("prefixHTy: unexpected type" ++ showAbstractH (ppType ty))
+
+\end{code}
+
+Prefixing
+
+\begin{code}
+infoHeader :: Decl -> Haskell.HDecl
+infoHeader d =
+ case d of
+  Interface i _ _ _ ->
+	 header "interface" (idOrigName i)  `andDecl`
+	 idlDecls			    `andDecl`
+         line
+
+  CoClass i _ ->
+	 header "coclass" (idOrigName i)    `andDecl`
+	 coIdlDecls			    `andDecl`
+         line
+ 
+  DispInterface i _ _ _ ->
+	 header "dispinterface" (idOrigName i)  `andDecl`
+	 idlDecls                               `andDecl`
+         line
+
+  _ -> emptyDecl
+ where
+  header pre nm = 
+    line                   `andDecl`
+    comment ""	           `andDecl`
+    comment (pre++' ':nm)  `andDecl`
+    comment ""
+	   
+  ifaces = 
+    case d of
+      CoClass _ ds -> map toStr ds
+      _ -> error "MarshallUtils.infoHeader: Expected a coclass."
+   
+  toStr dcl = 
+	let
+	 i     = coClassId dcl
+	 attrs = idAttributes i
+
+	 if_source
+	  | attrs `hasAttributeWithName` "source" = ("[source]" ++)
+	  | otherwise = id
+	in
+	if_source (idOrigName i)
+
+  coIdlDecls
+   | optShowIDLInComments = idlDecls
+   | otherwise		  =
+        comment ("  implements: "  ++ unwords (intersperse "," ifaces))
+
+  idlDecls
+   | optShowIDLInComments = andDecls (map comment (lines (showCore (setDebug False $ ppDecl d))))
+   | otherwise		  = emptyDecl
+
+  line = comment "--------------------------------------------------"
+ 
+
+\end{code}
+
+\begin{code}
+helpStringComment :: Id -> Haskell.HDecl
+helpStringComment i
+ | optIgnoreHelpstring = emptyDecl
+ | otherwise           =
+      case findAttribute "helpstring" (idAttributes i) of
+	Just (Attribute _ (ParamLit (StringLit hs):_)) -> comment hs
+        _ -> emptyDecl
+\end{code}
+
+The T-translation of interface types is provided as a separate function, as
+its needed by both MarshallType.toHaskellBaseTy and MarshallCore.toHaskellTy
+
+\begin{code}
+toHaskellIfaceTy :: Type -> Haskell.Type
+toHaskellIfaceTy (Iface nm mo _ attrs _ _)
+   -- dear, oh dear: special treatment of IUnknown and IDispatch just to make
+   -- AutoPrim.idl generate right looking code.
+ | optCorba = tyQCon  mo nm [iface_ptr_ty_arg]
+ | optHaskellToC  && nm `notElem` ["IUnknown", "IDispatch"] =
+    case findAttribute "ty_args" attrs of
+       Just (Attribute _ [ParamLit (StringLit s)]) -> tyQCon mo (mkHaskellTyConName nm) (map tyVar (words s))
+       _ -> tyQConst mo (mkHaskellTyConName nm)
+ | optJNI && attrs `hasAttributeWithName` "jni_iface_ty" =
+        let i = tyVar "a" in
+	mkTyCon jObject
+		[ ctxtTyApp (ctxtClass (mkQualName mo nm) [mkTyCon jObject [i]]) i ]
+ | optSubtypedInterfacePointers = tyQCon mo (mkHaskellTyConName nm) [iface_ptr_ty_arg]
+ | otherwise		        = tyQConst mo (mkHaskellTyConName nm)
+ where
+  iface_ptr_ty_arg = tyVar "a"
+toHaskellIfaceTy _ = error "toHaskellIfaceTy: not an interface type"
+\end{code}
+
+Given a parameter dependency list, figure out which parameters
+should be represented as a Haskell list.
+
+[This code is somewhat simplistic, as being a dependent doesn't necessarily 
+ mean that a pair of parameters to an IDL method should be coalesced
+ into a Haskell list.]
+
+\begin{code}
+findParamDependents :: Bool -> [Param] -> ( [Param], DependInfo )
+findParamDependents isOut ps = (removeDependees deps ps, deps)
+ where
+  deps = filter (notNull.snd) $     -- 12/98: strengthened - deps list now 
+				    -- only contain the real dependent args.
+         (if isOut then (\ ls -> zipWith notVoidPtr ps ls) else id) $
+	 findDependents (map paramId ps)
+
+  notVoidPtr _ t@(_,[]) = t
+  notVoidPtr p t@(x,_) 
+    | isVoidPointerTy (paramType p) = (x,[])
+    | otherwise = t
+
+findFieldDependents :: [Field] -> DependInfo
+findFieldDependents fs = deps
+ where
+  deps = filter (notNull.snd) $     -- 12/98: strengthened - deps list now 
+				    -- only contain the real dependent args.
+         (\ ls -> zipWith notVoidPtr fs ls) $
+	 findDependents (map fieldId fs)
+
+  notVoidPtr _ t@(_,[]) = t
+  notVoidPtr f t@(x,_) 
+    | isVoidPointerTy (fieldType f) = (x,[])
+    | otherwise = t
+
+
+removeDependees :: DependInfo -> [Param] -> [Param]
+removeDependees ls ps = filter (not.(isDependee ls).paramId) ps
+
+removeDependents :: DependInfo -> [Param] -> [Param]
+removeDependents ls ps = filter (not.(isHParamDep ls)) ps
+
+removeDependers :: DependInfo -> [Param] -> [Param]
+removeDependers ls ps = filter (\ x -> not (isDependee ls (paramId x)) &&
+				       not (isHParamDep ls x)) ps
+
+-- local utility fun, used by the two previous defs. only.
+isHParamDep :: DependInfo -> Param -> Bool
+isHParamDep ls p = isDepender ls (paramId p)
+
+\end{code}
+ src/MkImport.lhs view
@@ -0,0 +1,182 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 8th 2003  07:20  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Pass to construct import lists from a list of Haskell
+declarations.
+ 
+\begin{code}
+module MkImport 
+       (
+        mkImportLists
+       ) where
+
+import AbstractH
+import AbsHUtils ( ieType, andDecls, ieValue, mkQVarName, tyInt32Name )
+import Bag
+import Env
+import LibUtils  ( bitsLib, prelude, fromEnumName, toEnumName )
+import BasicTypes
+
+import List   ( nub )
+import Opts   ( optNoImportLists, optQualInstanceMethods, optNoQualNames,
+		optLongLongIsInteger )
+import Utils  ( concMaybe )
+\end{code}
+
+\begin{code}
+mkImportLists :: String
+              -> [QualName]
+	      -> [HDecl]
+	      -> [(String, Bool, [HIEEntity])]
+mkImportLists local_nm hs_imports decls = import_list
+  where
+   import_list = 
+		    -- sigh, to avoid pointless trouble with the generated
+		    -- sources due to Hugs' lack of support for qualified
+		    -- instance names, we optionally allow method names
+		    -- to be emitted in unqual'ed form. GHC (quite rightfully)
+		    -- complains when it is fed such input, since it has
+		    -- only got the qualified method name in scope.
+		    --
+		    -- To avoid the unfortunate situation that GHC and Hugs
+		    -- require separate Haskell stubs for normal stuff, we
+		    -- explicitly bring the unqual'ed Enum instance methods
+		    -- into scope.
+		    --
+		    -- A hack that doesn't solve the general problem.
+		    -- 
+   		 (if not optQualInstanceMethods && not optNoQualNames then 
+		     (("Prelude", False, [ ieValue (qName fromEnumName)
+		     			 , ieValue (qName toEnumName)
+					 ]):)
+		  else
+		     id) $
+		 ("Prelude", True, []):
+   		 filter ofInterest (map mkImpList (envToList (go (andDecls decls) new_env )))
+
+   new_env
+     | optLongLongIsInteger = addQName (\ nm -> ieType nm False) tyInt32Name base_env
+     | otherwise	    = base_env
+
+   base_env = foldr (addQName ieValue) newEnv hs_imports
+
+   ofInterest ("Prelude",_,_) = False
+   ofInterest (nm, _, _)      = nm /= local_nm
+
+   mkImpList (x, bag)	    = (x, True, nub (bagToList bag))
+
+   go :: HDecl -> Env String (Bag HIEEntity) -> Env String (Bag HIEEntity)
+   go (AndDecl d1 d2)	         env = go d2 (go d1 env)
+   go (TypeSig _ ctxt ty)        env = gatherTyImports ty (gatherTyContext ctxt env)
+   go (ValDecl _ _ es)	         env = foldr gatherGExprImports env es
+   go (TyD td)		         env = gatherTyDeclImports td env
+   go (Primitive _ _ _ _ ty _ _ _) env = gatherTyImports ty env
+   go (PrimCast _ _ ty _ _ _ )     env = gatherTyImports ty env
+   go (Entry _ _ _ ty)           env = gatherTyImports ty env
+   go (Callback _ _ ty)          env = gatherTyImports ty env
+   go (ExtLabel _ _ ty)          env = gatherTyImports ty env
+   go (Instance ctxt cname t ds) env =
+       gatherTyContext (Just ctxt) $
+       addQName (\ nm -> ieType nm False) cname $
+       gatherTyImports t $
+       foldr go env ds
+   go _                        env = env
+
+gatherTyImports :: Type -> Env String (Bag HIEEntity) -> Env String (Bag HIEEntity)
+gatherTyImports ty env = 
+ case ty of
+   TyVar _ tv     -> addQName (\ nm -> ieType nm True) tv env 
+   TyCon tc	  -> addQName (\ nm -> ieType nm True) tc env 
+   TyApply f args -> foldr gatherTyImports env (f:args)
+   TyList t	  -> gatherTyImports t env
+   TyTuple es	  -> foldr gatherTyImports env es
+   TyCtxt c t     -> gatherTyContext (Just c) (gatherTyImports t env)
+   TyFun f a	  -> gatherTyImports a (gatherTyImports f env)
+
+addQName :: (String -> a) -> QualName -> Env String (Bag a) -> Env String (Bag a)
+addQName f qn env = 
+   case concMaybe (qDefModule qn) (qModule qn) of
+     Nothing  -> env
+     v@(Just md)
+	    -- don't record what we're picking up from the Prelude.
+        | v == prelude -> env  
+	| otherwise    -> addToEnv_C (unionBags) env md nm
+       where
+        nm 
+	 | optNoImportLists = emptyBag
+	 | otherwise        = unitBag (f (qName qn))
+
+gatherTyDeclImports :: TyDecl -> Env String (Bag HIEEntity) -> Env String (Bag HIEEntity)
+gatherTyDeclImports (TypeSyn _ _ t) env     = gatherTyImports t env
+gatherTyDeclImports (TyDecl _ _ _ ds _) env = foldr gatherConDeclImport env ds
+ where
+  gatherConDeclImport (ConDecl _ ts) env1 = foldr gatherTyImports env1 (map debang ts)
+  gatherConDeclImport (RecDecl _ fs) env1 = foldr gatherTyImports env1 (map (debang.snd) fs)
+  
+  debang (Banged t)   = t
+  debang (Unbanged t) = t
+
+
+gatherTyContext :: Maybe Context -> Env String (Bag HIEEntity) -> Env String (Bag HIEEntity)
+gatherTyContext Nothing env = env
+gatherTyContext (Just ctxt) env = go ctxt env
+  where
+   go (CtxtClass nm _) env1 = addQName (\ n -> ieType n True) nm env1
+   go (CtxtTuple ls)   env1 = foldr go env1 ls
+
+gatherGExprImports :: GuardedExpr -> Env String (Bag HIEEntity) -> Env String (Bag HIEEntity)
+gatherGExprImports (GExpr es e) env = foldr gatherExprImports env (e:es)
+
+gatherExprImports :: Expr -> Env String (Bag HIEEntity) -> Env String (Bag HIEEntity)
+gatherExprImports e env =
+ case e of
+   Lam _ e1 -> gatherExprImports e1 env
+   Apply f args -> foldr gatherExprImports env (f:args)
+   Tup es -> foldr gatherExprImports env es
+   List es -> foldr gatherExprImports env es
+   BinOp bop e1 e2  -> gatherExprImports e2 (gatherExprImports e1 (gatherBinOpImports bop env))
+   InfixOp e1 op e2 -> gatherExprImports e1 (gatherExprImports e2 (addQName (ieValue) op env))
+   RApply e1 e2  -> gatherExprImports e1 (gatherExprImports e2 env)
+   UnOp op e1    -> gatherExprImports e1 (gatherUnaryOpImports op env)
+   Bind e1 _ e2  -> gatherExprImports e2 (gatherExprImports e1 env)
+   Bind_ e1 e2   -> gatherExprImports e2 (gatherExprImports e1 env)
+   Return e1     -> gatherExprImports e1 env
+   Case e1 alts  -> foldr gatherAltImports (gatherExprImports e1 env) alts
+   If e1 e2 e3   -> gatherExprImports e1 (gatherExprImports e2 (gatherExprImports e3 env))
+   Let binds e1  -> foldr gatherBindingImports (gatherExprImports e1 env) binds
+   Var v 	 -> addQName (ieValue) v env 
+   Con c	 -> addQName (ieValue) c env
+   WithTy e1 ty  -> gatherExprImports e1 (gatherTyImports ty env)
+   _		 -> env
+
+   where
+     gatherBindingImports (Binder _ e1) env1 = gatherExprImports e1 env1
+
+     gatherAltImports (Alt _ gs) env1    = foldr gatherExprImports env1 es
+       where
+        es = concatMap (\ (GExpr gs1 e1) -> e1:gs1) gs
+     gatherAltImports (Default _ e1) env1 = gatherExprImports e1 env1
+
+
+     gatherUnaryOpImports op env1 =
+        case op of
+	  Not -> addBitsImp "complement" env1
+	  _   -> env1
+
+     gatherBinOpImports op env1 =
+        case op of
+	  Xor -> addBitsImp "xor" env1
+	  Or  -> addBitsImp "(.|.)" env1
+	  And -> addBitsImp "(.&.)" env1
+	  Shift L -> addBitsImp "shiftL" env1
+	  Shift R -> addBitsImp "shiftR" env1
+	  _ -> env1
+	  
+	  
+     addBitsImp nm env1 = addQName ieValue (mkQVarName bitsLib nm) env1
+
+\end{code}
+ src/NameSupply.lhs view
@@ -0,0 +1,62 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Aug. 21th 2001  23:14  Sigbjorn Finne $
+% @(#) $Contactid: sof@galconn.com $
+%
+
+Basic name supply monad.
+
+\begin{code}
+
+module NameSupply
+	( NSM		-- instance {Functor,Monad} NSM
+        , getNewName	-- :: NSM String
+	, withNewName   -- :: String -> NSM a -> NSM a
+        , getNewNames	-- :: Int -> NSM [String]
+	, mapNSM
+        , runNS
+	) where
+
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Monadic plumbing for Name Supply}
+%*									*
+%************************************************************************
+
+\begin{code}
+
+type NameSupply = [String]
+
+newtype NSM a = NSM (NameSupply -> (a, NameSupply))
+
+mapNSM :: (a -> b) -> NSM a -> NSM b
+mapNSM f (NSM g) = NSM (\ns -> let (a, ns') = g ns in (f a, ns'))
+
+instance Monad NSM where
+  (NSM f) >>= g	= 
+    NSM (\ns -> let (result1, ns1)	= f ns
+                    (NSM h)		= g result1 
+                in h ns1)
+  return a	= NSM (\ns -> (a, ns))
+
+getNewNames :: Int -> NSM [String]
+getNewNames i = NSM (\ns -> splitAt i ns)
+
+getNewName :: NSM String
+getNewName = NSM (\ns -> (head ns, tail ns))
+
+withNewName :: String -> NSM a -> NSM a
+withNewName n (NSM f) = NSM $ \ ns ->
+  case f (n:ns) of
+    (v, ns') -> case ns' of
+    		  (x:xs) | x == n -> (v, xs) 
+		      -- make sure we remove the name added.
+		  _ -> (v, ns')
+
+runNS :: NSM a -> [String] -> a
+runNS (NSM f) ns = fst (f ns)
+
+\end{code}
+ src/NativeInfo.hs view
@@ -0,0 +1,58 @@+-- This file was created by mkNativeInfo. Do not edit by hand.
+
+module NativeInfo where
+
+fLOAT_SIZE :: Int
+fLOAT_SIZE = 4
+fLOAT_ALIGN_MODULUS :: Int
+fLOAT_ALIGN_MODULUS = 4
+dOUBLE_SIZE :: Int
+dOUBLE_SIZE = 8
+dOUBLE_ALIGN_MODULUS :: Int
+dOUBLE_ALIGN_MODULUS = 8
+sHORT_SIZE :: Int
+sHORT_SIZE = 2
+sHORT_ALIGN_MODULUS :: Int
+sHORT_ALIGN_MODULUS = 2
+lONG_SIZE :: Int
+lONG_SIZE = 4
+lONG_ALIGN_MODULUS :: Int
+lONG_ALIGN_MODULUS = 4
+lONGLONG_SIZE :: Int
+lONGLONG_SIZE = 8
+lONGLONG_ALIGN_MODULUS :: Int
+lONGLONG_ALIGN_MODULUS = 8
+uSHORT_SIZE :: Int
+uSHORT_SIZE = 2
+uSHORT_ALIGN_MODULUS :: Int
+uSHORT_ALIGN_MODULUS = 2
+uLONG_SIZE :: Int
+uLONG_SIZE = 4
+uLONG_ALIGN_MODULUS :: Int
+uLONG_ALIGN_MODULUS = 4
+uLONGLONG_SIZE :: Int
+uLONGLONG_SIZE = 8
+uLONGLONG_ALIGN_MODULUS :: Int
+uLONGLONG_ALIGN_MODULUS = 8
+uCHAR_SIZE :: Int
+uCHAR_SIZE = 1
+uCHAR_ALIGN_MODULUS :: Int
+uCHAR_ALIGN_MODULUS = 1
+sCHAR_SIZE :: Int
+sCHAR_SIZE = 1
+sCHAR_ALIGN_MODULUS :: Int
+sCHAR_ALIGN_MODULUS = 1
+dATA_PTR_SIZE :: Int
+dATA_PTR_SIZE = 4
+dATA_PTR_ALIGN_MODULUS :: Int
+dATA_PTR_ALIGN_MODULUS = 4
+bSTR_SIZE :: Int
+bSTR_SIZE = 4
+bSTR_ALIGN_MODULUS :: Int
+bSTR_ALIGN_MODULUS = 4
+sAFEARRAY_SIZE :: Int
+sAFEARRAY_SIZE = 24
+sAFEARRAY_ALIGN_MODULUS :: Int
+sAFEARRAY_ALIGN_MODULUS = 4
+sTRUCT_ALIGN_MODULUS ::Int
+sTRUCT_ALIGN_MODULUS = 1
+ src/NormaliseType.lhs view
@@ -0,0 +1,60 @@+% 
+% (c) sof, 1999
+%
+
+All types are normalised before code generation, so that
+we can avoid the generation of extraneous marshalling code
+(and marshallers.)
+
+Notice that the compiler makes a distinction between IDL types
+that are used when generating Haskell type signatures and the
+types that are used when generating marshalling code. The former
+is not normalised in any way, since we want the Haskell signature to
+mirror the IDL signature as much as possible; it is only the
+latter that is subject to normalisation => we keep track of
+both 
+
+\begin{code}
+module NormaliseType (normaliseType) where
+
+import CoreIDL
+import CoreUtils ( isConstructedTy )
+\end{code}
+
+\begin{code}
+normaliseType :: Type -> Type
+normaliseType ty = 
+  case ty of
+      -- types containing TypeInfo records are considered 'important',
+      -- so we don't attempt to expand them out.
+    Name _ _ _ _ _ (Just _) -> ty
+      -- Chasing down name chains do run the risk of looping, should
+      -- the desugarer have created a name which is the infinite expansion
+      -- of itself. That Should Not Happen (any longer.)
+    Name _ _ _ _ (Just t) _  | not (isConstructedTy t) -> normaliseType t
+    FunTy cc res ps ->  FunTy cc (normaliseResult res) (map normaliseParam ps)
+    String t u mb_e   ->  String (normaliseType t) u mb_e
+    Sequence t mb_e mb_term ->  Sequence (normaliseType t) mb_e mb_term
+    Struct i fs s   ->  Struct i (map normaliseField fs) s
+    Union i1 t i2 i3 sws -> Union i1 (normaliseType t) i2 i3 (map normaliseSwitch sws)
+    UnionNon i sws  ->  UnionNon i (map normaliseSwitch sws)
+    CUnion i fs s   ->  CUnion i (map normaliseField fs) s
+    Pointer pt isExp t ->  Pointer pt isExp (normaliseType t)
+    Array t es      ->  Array (normaliseType t) es
+    SafeArray t     ->  SafeArray (normaliseType t)
+    _		    -> ty
+
+normaliseResult :: Result -> Result
+normaliseResult r = r{resultType=normaliseType (resultType r)}
+
+normaliseParam :: Param -> Param
+normaliseParam p = p{paramType=normaliseType (paramType p)}
+
+normaliseField :: Field -> Field
+normaliseField f = f{fieldType=normaliseType (fieldType f)}
+
+normaliseSwitch :: Switch -> Switch
+normaliseSwitch s@SwitchEmpty{} = s
+normaliseSwitch s = s{switchType=normaliseType (switchType s)}
+
+\end{code}
+ src/OmgParser.hs view
@@ -0,0 +1,3674 @@+-- parser produced by Happy Version 1.13
+
+{-
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+% @(#) $Docid: Jul. 12th 2001  10:08  Sigbjorn Finne $
+% @(#) $Contactid: sof@galconn.com $
+%
+
+A grammar for OMG CORBA IDL
+
+-}
+module OmgParser ( parseIDL ) where
+
+import LexM
+import Lex
+import IDLToken
+import IDLSyn
+import BasicTypes
+import Literal
+{-
+BEGIN_GHC_ONLY
+import GlaExts
+END_GHC_ONLY
+-}
+
+data HappyAbsSyn 
+	= HappyTerminal IDLToken
+	| HappyErrorToken Int
+	| HappyAbsSyn4 ([Defn])
+	| HappyAbsSyn6 (Defn)
+	| HappyAbsSyn10 ((Id, Inherit))
+	| HappyAbsSyn13 (Inherit)
+	| HappyAbsSyn15 (String)
+	| HappyAbsSyn18 (Type)
+	| HappyAbsSyn19 (Expr)
+	| HappyAbsSyn27 (UnaryOp)
+	| HappyAbsSyn29 (Literal)
+	| HappyAbsSyn32 ((Type, [Id]))
+	| HappyAbsSyn38 ([Id])
+	| HappyAbsSyn39 (Id)
+	| HappyAbsSyn50 ([Member])
+	| HappyAbsSyn51 (Member)
+	| HappyAbsSyn54 ([Switch])
+	| HappyAbsSyn55 (Switch)
+	| HappyAbsSyn56 ([CaseLabel])
+	| HappyAbsSyn57 (CaseLabel)
+	| HappyAbsSyn58 (SwitchArm)
+	| HappyAbsSyn60 ([(Id,[Attribute],Maybe Expr)])
+	| HappyAbsSyn64 ((Id, [Expr]))
+	| HappyAbsSyn65 ([Expr])
+	| HappyAbsSyn68 (Bool)
+	| HappyAbsSyn76 ([Param])
+	| HappyAbsSyn78 (Param)
+	| HappyAbsSyn79 (Attribute)
+	| HappyAbsSyn80 (Maybe Raises)
+	| HappyAbsSyn81 (Maybe Context)
+	| HappyAbsSyn82 ([String])
+	| HappyAbsSyn87 (IntegerLit)
+
+type HappyReduction = 
+	   Int 
+	-> (IDLToken)
+	-> HappyState (IDLToken) (HappyStk HappyAbsSyn -> LexM(HappyAbsSyn))
+	-> [HappyState (IDLToken) (HappyStk HappyAbsSyn -> LexM(HappyAbsSyn))] 
+	-> HappyStk HappyAbsSyn 
+	-> LexM(HappyAbsSyn)
+
+action_0,
+ action_1,
+ action_2,
+ action_3,
+ action_4,
+ action_5,
+ action_6,
+ action_7,
+ action_8,
+ action_9,
+ action_10,
+ action_11,
+ action_12,
+ action_13,
+ action_14,
+ action_15,
+ action_16,
+ action_17,
+ action_18,
+ action_19,
+ action_20,
+ action_21,
+ action_22,
+ action_23,
+ action_24,
+ action_25,
+ action_26,
+ action_27,
+ action_28,
+ action_29,
+ action_30,
+ action_31,
+ action_32,
+ action_33,
+ action_34,
+ action_35,
+ action_36,
+ action_37,
+ action_38,
+ action_39,
+ action_40,
+ action_41,
+ action_42,
+ action_43,
+ action_44,
+ action_45,
+ action_46,
+ action_47,
+ action_48,
+ action_49,
+ action_50,
+ action_51,
+ action_52,
+ action_53,
+ action_54,
+ action_55,
+ action_56,
+ action_57,
+ action_58,
+ action_59,
+ action_60,
+ action_61,
+ action_62,
+ action_63,
+ action_64,
+ action_65,
+ action_66,
+ action_67,
+ action_68,
+ action_69,
+ action_70,
+ action_71,
+ action_72,
+ action_73,
+ action_74,
+ action_75,
+ action_76,
+ action_77,
+ action_78,
+ action_79,
+ action_80,
+ action_81,
+ action_82,
+ action_83,
+ action_84,
+ action_85,
+ action_86,
+ action_87,
+ action_88,
+ action_89,
+ action_90,
+ action_91,
+ action_92,
+ action_93,
+ action_94,
+ action_95,
+ action_96,
+ action_97,
+ action_98,
+ action_99,
+ action_100,
+ action_101,
+ action_102,
+ action_103,
+ action_104,
+ action_105,
+ action_106,
+ action_107,
+ action_108,
+ action_109,
+ action_110,
+ action_111,
+ action_112,
+ action_113,
+ action_114,
+ action_115,
+ action_116,
+ action_117,
+ action_118,
+ action_119,
+ action_120,
+ action_121,
+ action_122,
+ action_123,
+ action_124,
+ action_125,
+ action_126,
+ action_127,
+ action_128,
+ action_129,
+ action_130,
+ action_131,
+ action_132,
+ action_133,
+ action_134,
+ action_135,
+ action_136,
+ action_137,
+ action_138,
+ action_139,
+ action_140,
+ action_141,
+ action_142,
+ action_143,
+ action_144,
+ action_145,
+ action_146,
+ action_147,
+ action_148,
+ action_149,
+ action_150,
+ action_151,
+ action_152,
+ action_153,
+ action_154,
+ action_155,
+ action_156,
+ action_157,
+ action_158,
+ action_159,
+ action_160,
+ action_161,
+ action_162,
+ action_163,
+ action_164,
+ action_165,
+ action_166,
+ action_167,
+ action_168,
+ action_169,
+ action_170,
+ action_171,
+ action_172,
+ action_173,
+ action_174,
+ action_175,
+ action_176,
+ action_177,
+ action_178,
+ action_179,
+ action_180,
+ action_181,
+ action_182,
+ action_183,
+ action_184,
+ action_185,
+ action_186,
+ action_187,
+ action_188,
+ action_189,
+ action_190,
+ action_191,
+ action_192,
+ action_193,
+ action_194,
+ action_195,
+ action_196,
+ action_197,
+ action_198,
+ action_199,
+ action_200,
+ action_201,
+ action_202,
+ action_203,
+ action_204,
+ action_205,
+ action_206,
+ action_207,
+ action_208,
+ action_209,
+ action_210,
+ action_211,
+ action_212,
+ action_213,
+ action_214,
+ action_215,
+ action_216,
+ action_217,
+ action_218,
+ action_219,
+ action_220,
+ action_221,
+ action_222,
+ action_223,
+ action_224,
+ action_225,
+ action_226,
+ action_227,
+ action_228,
+ action_229,
+ action_230,
+ action_231,
+ action_232,
+ action_233,
+ action_234,
+ action_235,
+ action_236,
+ action_237,
+ action_238,
+ action_239,
+ action_240,
+ action_241,
+ action_242,
+ action_243,
+ action_244,
+ action_245,
+ action_246,
+ action_247,
+ action_248,
+ action_249,
+ action_250,
+ action_251,
+ action_252,
+ action_253,
+ action_254,
+ action_255,
+ action_256,
+ action_257,
+ action_258,
+ action_259,
+ action_260,
+ action_261,
+ action_262,
+ action_263,
+ action_264,
+ action_265,
+ action_266,
+ action_267,
+ action_268,
+ action_269,
+ action_270,
+ action_271,
+ action_272,
+ action_273,
+ action_274,
+ action_275,
+ action_276,
+ action_277 :: Int -> HappyReduction
+
+happyReduce_1,
+ happyReduce_2,
+ happyReduce_3,
+ happyReduce_4,
+ happyReduce_5,
+ happyReduce_6,
+ happyReduce_7,
+ happyReduce_8,
+ happyReduce_9,
+ happyReduce_10,
+ happyReduce_11,
+ happyReduce_12,
+ happyReduce_13,
+ happyReduce_14,
+ happyReduce_15,
+ happyReduce_16,
+ happyReduce_17,
+ happyReduce_18,
+ happyReduce_19,
+ happyReduce_20,
+ happyReduce_21,
+ happyReduce_22,
+ happyReduce_23,
+ happyReduce_24,
+ happyReduce_25,
+ happyReduce_26,
+ happyReduce_27,
+ happyReduce_28,
+ happyReduce_29,
+ happyReduce_30,
+ happyReduce_31,
+ happyReduce_32,
+ happyReduce_33,
+ happyReduce_34,
+ happyReduce_35,
+ happyReduce_36,
+ happyReduce_37,
+ happyReduce_38,
+ happyReduce_39,
+ happyReduce_40,
+ happyReduce_41,
+ happyReduce_42,
+ happyReduce_43,
+ happyReduce_44,
+ happyReduce_45,
+ happyReduce_46,
+ happyReduce_47,
+ happyReduce_48,
+ happyReduce_49,
+ happyReduce_50,
+ happyReduce_51,
+ happyReduce_52,
+ happyReduce_53,
+ happyReduce_54,
+ happyReduce_55,
+ happyReduce_56,
+ happyReduce_57,
+ happyReduce_58,
+ happyReduce_59,
+ happyReduce_60,
+ happyReduce_61,
+ happyReduce_62,
+ happyReduce_63,
+ happyReduce_64,
+ happyReduce_65,
+ happyReduce_66,
+ happyReduce_67,
+ happyReduce_68,
+ happyReduce_69,
+ happyReduce_70,
+ happyReduce_71,
+ happyReduce_72,
+ happyReduce_73,
+ happyReduce_74,
+ happyReduce_75,
+ happyReduce_76,
+ happyReduce_77,
+ happyReduce_78,
+ happyReduce_79,
+ happyReduce_80,
+ happyReduce_81,
+ happyReduce_82,
+ happyReduce_83,
+ happyReduce_84,
+ happyReduce_85,
+ happyReduce_86,
+ happyReduce_87,
+ happyReduce_88,
+ happyReduce_89,
+ happyReduce_90,
+ happyReduce_91,
+ happyReduce_92,
+ happyReduce_93,
+ happyReduce_94,
+ happyReduce_95,
+ happyReduce_96,
+ happyReduce_97,
+ happyReduce_98,
+ happyReduce_99,
+ happyReduce_100,
+ happyReduce_101,
+ happyReduce_102,
+ happyReduce_103,
+ happyReduce_104,
+ happyReduce_105,
+ happyReduce_106,
+ happyReduce_107,
+ happyReduce_108,
+ happyReduce_109,
+ happyReduce_110,
+ happyReduce_111,
+ happyReduce_112,
+ happyReduce_113,
+ happyReduce_114,
+ happyReduce_115,
+ happyReduce_116,
+ happyReduce_117,
+ happyReduce_118,
+ happyReduce_119,
+ happyReduce_120,
+ happyReduce_121,
+ happyReduce_122,
+ happyReduce_123,
+ happyReduce_124,
+ happyReduce_125,
+ happyReduce_126,
+ happyReduce_127,
+ happyReduce_128,
+ happyReduce_129,
+ happyReduce_130,
+ happyReduce_131,
+ happyReduce_132,
+ happyReduce_133,
+ happyReduce_134,
+ happyReduce_135,
+ happyReduce_136,
+ happyReduce_137,
+ happyReduce_138,
+ happyReduce_139,
+ happyReduce_140,
+ happyReduce_141,
+ happyReduce_142,
+ happyReduce_143,
+ happyReduce_144,
+ happyReduce_145,
+ happyReduce_146,
+ happyReduce_147,
+ happyReduce_148,
+ happyReduce_149,
+ happyReduce_150,
+ happyReduce_151,
+ happyReduce_152,
+ happyReduce_153,
+ happyReduce_154,
+ happyReduce_155,
+ happyReduce_156,
+ happyReduce_157,
+ happyReduce_158,
+ happyReduce_159,
+ happyReduce_160,
+ happyReduce_161,
+ happyReduce_162,
+ happyReduce_163,
+ happyReduce_164,
+ happyReduce_165,
+ happyReduce_166,
+ happyReduce_167,
+ happyReduce_168,
+ happyReduce_169,
+ happyReduce_170,
+ happyReduce_171,
+ happyReduce_172,
+ happyReduce_173,
+ happyReduce_174,
+ happyReduce_175,
+ happyReduce_176 :: HappyReduction
+
+action_0 (4) = happyGoto action_3
+action_0 (5) = happyGoto action_2
+action_0 _ = happyReduce_2
+
+action_1 (5) = happyGoto action_2
+action_1 _ = happyFail
+
+action_2 (91) = happyShift action_15
+action_2 (92) = happyShift action_16
+action_2 (101) = happyShift action_17
+action_2 (116) = happyShift action_18
+action_2 (125) = happyShift action_19
+action_2 (126) = happyShift action_20
+action_2 (130) = happyShift action_21
+action_2 (154) = happyShift action_22
+action_2 (158) = happyShift action_23
+action_2 (159) = happyShift action_24
+action_2 (160) = happyShift action_25
+action_2 (6) = happyGoto action_4
+action_2 (7) = happyGoto action_5
+action_2 (8) = happyGoto action_6
+action_2 (9) = happyGoto action_7
+action_2 (10) = happyGoto action_8
+action_2 (17) = happyGoto action_9
+action_2 (31) = happyGoto action_10
+action_2 (49) = happyGoto action_11
+action_2 (52) = happyGoto action_12
+action_2 (59) = happyGoto action_13
+action_2 (70) = happyGoto action_14
+action_2 _ = happyReduce_1
+
+action_3 (162) = happyAccept
+action_3 _ = happyFail
+
+action_4 _ = happyReduce_3
+
+action_5 (90) = happyShift action_87
+action_5 _ = happyFail
+
+action_6 (90) = happyShift action_86
+action_6 _ = happyFail
+
+action_7 _ = happyReduce_13
+
+action_8 (95) = happyShift action_85
+action_8 _ = happyFail
+
+action_9 (90) = happyShift action_84
+action_9 _ = happyFail
+
+action_10 (90) = happyShift action_83
+action_10 _ = happyFail
+
+action_11 _ = happyReduce_68
+
+action_12 _ = happyReduce_69
+
+action_13 _ = happyReduce_70
+
+action_14 (90) = happyShift action_82
+action_14 _ = happyFail
+
+action_15 (141) = happyShift action_27
+action_15 (89) = happyGoto action_81
+action_15 _ = happyFail
+
+action_16 (141) = happyShift action_27
+action_16 (89) = happyGoto action_80
+action_16 _ = happyFail
+
+action_17 (98) = happyShift action_53
+action_17 (118) = happyShift action_54
+action_17 (119) = happyShift action_55
+action_17 (120) = happyShift action_56
+action_17 (121) = happyShift action_57
+action_17 (122) = happyShift action_58
+action_17 (123) = happyShift action_59
+action_17 (124) = happyShift action_60
+action_17 (141) = happyShift action_61
+action_17 (146) = happyShift action_62
+action_17 (147) = happyShift action_63
+action_17 (153) = happyShift action_79
+action_17 (15) = happyGoto action_69
+action_17 (18) = happyGoto action_70
+action_17 (41) = happyGoto action_71
+action_17 (42) = happyGoto action_72
+action_17 (43) = happyGoto action_73
+action_17 (44) = happyGoto action_74
+action_17 (45) = happyGoto action_75
+action_17 (62) = happyGoto action_76
+action_17 (63) = happyGoto action_77
+action_17 (86) = happyGoto action_78
+action_17 _ = happyFail
+
+action_18 (98) = happyShift action_53
+action_18 (118) = happyShift action_54
+action_18 (119) = happyShift action_55
+action_18 (120) = happyShift action_56
+action_18 (121) = happyShift action_57
+action_18 (122) = happyShift action_58
+action_18 (123) = happyShift action_59
+action_18 (124) = happyShift action_60
+action_18 (125) = happyShift action_19
+action_18 (126) = happyShift action_20
+action_18 (130) = happyShift action_21
+action_18 (141) = happyShift action_61
+action_18 (146) = happyShift action_62
+action_18 (147) = happyShift action_63
+action_18 (148) = happyShift action_64
+action_18 (149) = happyShift action_65
+action_18 (150) = happyShift action_66
+action_18 (151) = happyShift action_67
+action_18 (153) = happyShift action_68
+action_18 (15) = happyGoto action_31
+action_18 (32) = happyGoto action_32
+action_18 (33) = happyGoto action_33
+action_18 (34) = happyGoto action_34
+action_18 (35) = happyGoto action_35
+action_18 (36) = happyGoto action_36
+action_18 (37) = happyGoto action_37
+action_18 (41) = happyGoto action_38
+action_18 (42) = happyGoto action_39
+action_18 (43) = happyGoto action_40
+action_18 (44) = happyGoto action_41
+action_18 (45) = happyGoto action_42
+action_18 (46) = happyGoto action_43
+action_18 (47) = happyGoto action_44
+action_18 (48) = happyGoto action_45
+action_18 (49) = happyGoto action_46
+action_18 (52) = happyGoto action_47
+action_18 (59) = happyGoto action_48
+action_18 (61) = happyGoto action_49
+action_18 (62) = happyGoto action_50
+action_18 (63) = happyGoto action_51
+action_18 (85) = happyGoto action_52
+action_18 _ = happyFail
+
+action_19 (141) = happyShift action_27
+action_19 (89) = happyGoto action_30
+action_19 _ = happyFail
+
+action_20 (141) = happyShift action_27
+action_20 (89) = happyGoto action_29
+action_20 _ = happyFail
+
+action_21 (141) = happyShift action_27
+action_21 (89) = happyGoto action_28
+action_21 _ = happyFail
+
+action_22 (141) = happyShift action_27
+action_22 (89) = happyGoto action_26
+action_22 _ = happyFail
+
+action_23 _ = happyReduce_10
+
+action_24 _ = happyReduce_11
+
+action_25 _ = happyReduce_9
+
+action_26 (95) = happyShift action_108
+action_26 _ = happyFail
+
+action_27 _ = happyReduce_176
+
+action_28 (95) = happyShift action_107
+action_28 _ = happyFail
+
+action_29 (127) = happyShift action_106
+action_29 _ = happyFail
+
+action_30 (95) = happyShift action_105
+action_30 _ = happyFail
+
+action_31 (98) = happyShift action_94
+action_31 _ = happyReduce_76
+
+action_32 _ = happyReduce_67
+
+action_33 (141) = happyShift action_27
+action_33 (38) = happyGoto action_102
+action_33 (40) = happyGoto action_103
+action_33 (89) = happyGoto action_104
+action_33 _ = happyFail
+
+action_34 _ = happyReduce_72
+
+action_35 _ = happyReduce_74
+
+action_36 _ = happyReduce_75
+
+action_37 _ = happyReduce_73
+
+action_38 _ = happyReduce_77
+
+action_39 _ = happyReduce_78
+
+action_40 _ = happyReduce_79
+
+action_41 _ = happyReduce_80
+
+action_42 _ = happyReduce_81
+
+action_43 _ = happyReduce_82
+
+action_44 _ = happyReduce_83
+
+action_45 _ = happyReduce_84
+
+action_46 _ = happyReduce_89
+
+action_47 _ = happyReduce_90
+
+action_48 _ = happyReduce_91
+
+action_49 _ = happyReduce_85
+
+action_50 _ = happyReduce_86
+
+action_51 _ = happyReduce_87
+
+action_52 _ = happyReduce_88
+
+action_53 (141) = happyShift action_101
+action_53 _ = happyFail
+
+action_54 _ = happyReduce_97
+
+action_55 _ = happyReduce_98
+
+action_56 (119) = happyShift action_100
+action_56 _ = happyFail
+
+action_57 (119) = happyShift action_99
+action_57 _ = happyFail
+
+action_58 _ = happyReduce_101
+
+action_59 _ = happyReduce_102
+
+action_60 _ = happyReduce_103
+
+action_61 _ = happyReduce_27
+
+action_62 (131) = happyShift action_98
+action_62 _ = happyReduce_131
+
+action_63 (131) = happyShift action_97
+action_63 _ = happyReduce_133
+
+action_64 (131) = happyShift action_96
+action_64 _ = happyFail
+
+action_65 _ = happyReduce_106
+
+action_66 _ = happyReduce_105
+
+action_67 _ = happyReduce_104
+
+action_68 (131) = happyShift action_95
+action_68 _ = happyFail
+
+action_69 (98) = happyShift action_94
+action_69 _ = happyReduce_41
+
+action_70 (141) = happyShift action_27
+action_70 (89) = happyGoto action_93
+action_70 _ = happyFail
+
+action_71 _ = happyReduce_37
+
+action_72 _ = happyReduce_33
+
+action_73 _ = happyReduce_34
+
+action_74 _ = happyReduce_35
+
+action_75 _ = happyReduce_36
+
+action_76 _ = happyReduce_38
+
+action_77 _ = happyReduce_39
+
+action_78 _ = happyReduce_40
+
+action_79 _ = happyReduce_173
+
+action_80 (95) = happyReduce_24
+action_80 (97) = happyShift action_92
+action_80 (13) = happyGoto action_90
+action_80 (14) = happyGoto action_91
+action_80 _ = happyReduce_14
+
+action_81 (95) = happyShift action_89
+action_81 _ = happyFail
+
+action_82 _ = happyReduce_6
+
+action_83 _ = happyReduce_4
+
+action_84 _ = happyReduce_5
+
+action_85 (11) = happyGoto action_88
+action_85 _ = happyReduce_17
+
+action_86 _ = happyReduce_7
+
+action_87 _ = happyReduce_8
+
+action_88 (96) = happyShift action_154
+action_88 (101) = happyShift action_17
+action_88 (116) = happyShift action_18
+action_88 (125) = happyShift action_19
+action_88 (126) = happyShift action_20
+action_88 (130) = happyShift action_21
+action_88 (142) = happyReduce_140
+action_88 (152) = happyShift action_155
+action_88 (154) = happyShift action_22
+action_88 (157) = happyShift action_156
+action_88 (12) = happyGoto action_146
+action_88 (17) = happyGoto action_147
+action_88 (31) = happyGoto action_148
+action_88 (49) = happyGoto action_11
+action_88 (52) = happyGoto action_12
+action_88 (59) = happyGoto action_13
+action_88 (67) = happyGoto action_149
+action_88 (68) = happyGoto action_150
+action_88 (70) = happyGoto action_151
+action_88 (73) = happyGoto action_152
+action_88 (74) = happyGoto action_153
+action_88 _ = happyReduce_149
+
+action_89 (5) = happyGoto action_145
+action_89 _ = happyReduce_2
+
+action_90 _ = happyReduce_16
+
+action_91 _ = happyReduce_25
+
+action_92 (98) = happyShift action_53
+action_92 (141) = happyShift action_61
+action_92 (15) = happyGoto action_144
+action_92 _ = happyFail
+
+action_93 (102) = happyShift action_143
+action_93 _ = happyFail
+
+action_94 (141) = happyShift action_142
+action_94 _ = happyFail
+
+action_95 (98) = happyShift action_53
+action_95 (113) = happyShift action_135
+action_95 (139) = happyShift action_136
+action_95 (141) = happyShift action_61
+action_95 (143) = happyShift action_137
+action_95 (145) = happyShift action_138
+action_95 (15) = happyGoto action_122
+action_95 (19) = happyGoto action_123
+action_95 (20) = happyGoto action_124
+action_95 (21) = happyGoto action_125
+action_95 (22) = happyGoto action_126
+action_95 (23) = happyGoto action_127
+action_95 (24) = happyGoto action_128
+action_95 (25) = happyGoto action_129
+action_95 (26) = happyGoto action_130
+action_95 (27) = happyGoto action_131
+action_95 (28) = happyGoto action_132
+action_95 (29) = happyGoto action_133
+action_95 (30) = happyGoto action_141
+action_95 _ = happyFail
+
+action_96 (98) = happyShift action_53
+action_96 (118) = happyShift action_54
+action_96 (119) = happyShift action_55
+action_96 (120) = happyShift action_56
+action_96 (121) = happyShift action_57
+action_96 (122) = happyShift action_58
+action_96 (123) = happyShift action_59
+action_96 (124) = happyShift action_60
+action_96 (141) = happyShift action_61
+action_96 (146) = happyShift action_62
+action_96 (147) = happyShift action_63
+action_96 (148) = happyShift action_64
+action_96 (149) = happyShift action_65
+action_96 (150) = happyShift action_66
+action_96 (151) = happyShift action_67
+action_96 (153) = happyShift action_68
+action_96 (15) = happyGoto action_31
+action_96 (34) = happyGoto action_140
+action_96 (35) = happyGoto action_35
+action_96 (36) = happyGoto action_36
+action_96 (41) = happyGoto action_38
+action_96 (42) = happyGoto action_39
+action_96 (43) = happyGoto action_40
+action_96 (44) = happyGoto action_41
+action_96 (45) = happyGoto action_42
+action_96 (46) = happyGoto action_43
+action_96 (47) = happyGoto action_44
+action_96 (48) = happyGoto action_45
+action_96 (61) = happyGoto action_49
+action_96 (62) = happyGoto action_50
+action_96 (63) = happyGoto action_51
+action_96 (85) = happyGoto action_52
+action_96 _ = happyFail
+
+action_97 (98) = happyShift action_53
+action_97 (113) = happyShift action_135
+action_97 (139) = happyShift action_136
+action_97 (141) = happyShift action_61
+action_97 (143) = happyShift action_137
+action_97 (145) = happyShift action_138
+action_97 (15) = happyGoto action_122
+action_97 (19) = happyGoto action_123
+action_97 (20) = happyGoto action_124
+action_97 (21) = happyGoto action_125
+action_97 (22) = happyGoto action_126
+action_97 (23) = happyGoto action_127
+action_97 (24) = happyGoto action_128
+action_97 (25) = happyGoto action_129
+action_97 (26) = happyGoto action_130
+action_97 (27) = happyGoto action_131
+action_97 (28) = happyGoto action_132
+action_97 (29) = happyGoto action_133
+action_97 (30) = happyGoto action_139
+action_97 _ = happyFail
+
+action_98 (98) = happyShift action_53
+action_98 (113) = happyShift action_135
+action_98 (139) = happyShift action_136
+action_98 (141) = happyShift action_61
+action_98 (143) = happyShift action_137
+action_98 (145) = happyShift action_138
+action_98 (15) = happyGoto action_122
+action_98 (19) = happyGoto action_123
+action_98 (20) = happyGoto action_124
+action_98 (21) = happyGoto action_125
+action_98 (22) = happyGoto action_126
+action_98 (23) = happyGoto action_127
+action_98 (24) = happyGoto action_128
+action_98 (25) = happyGoto action_129
+action_98 (26) = happyGoto action_130
+action_98 (27) = happyGoto action_131
+action_98 (28) = happyGoto action_132
+action_98 (29) = happyGoto action_133
+action_98 (30) = happyGoto action_134
+action_98 _ = happyFail
+
+action_99 _ = happyReduce_99
+
+action_100 _ = happyReduce_100
+
+action_101 _ = happyReduce_28
+
+action_102 (99) = happyShift action_121
+action_102 _ = happyReduce_71
+
+action_103 _ = happyReduce_92
+
+action_104 (135) = happyShift action_120
+action_104 (65) = happyGoto action_118
+action_104 (66) = happyGoto action_119
+action_104 _ = happyReduce_95
+
+action_105 (98) = happyShift action_53
+action_105 (118) = happyShift action_54
+action_105 (119) = happyShift action_55
+action_105 (120) = happyShift action_56
+action_105 (121) = happyShift action_57
+action_105 (122) = happyShift action_58
+action_105 (123) = happyShift action_59
+action_105 (124) = happyShift action_60
+action_105 (125) = happyShift action_19
+action_105 (126) = happyShift action_20
+action_105 (130) = happyShift action_21
+action_105 (141) = happyShift action_61
+action_105 (146) = happyShift action_62
+action_105 (147) = happyShift action_63
+action_105 (148) = happyShift action_64
+action_105 (149) = happyShift action_65
+action_105 (150) = happyShift action_66
+action_105 (151) = happyShift action_67
+action_105 (153) = happyShift action_68
+action_105 (15) = happyGoto action_31
+action_105 (33) = happyGoto action_109
+action_105 (34) = happyGoto action_34
+action_105 (35) = happyGoto action_35
+action_105 (36) = happyGoto action_36
+action_105 (37) = happyGoto action_37
+action_105 (41) = happyGoto action_38
+action_105 (42) = happyGoto action_39
+action_105 (43) = happyGoto action_40
+action_105 (44) = happyGoto action_41
+action_105 (45) = happyGoto action_42
+action_105 (46) = happyGoto action_43
+action_105 (47) = happyGoto action_44
+action_105 (48) = happyGoto action_45
+action_105 (49) = happyGoto action_46
+action_105 (50) = happyGoto action_116
+action_105 (51) = happyGoto action_117
+action_105 (52) = happyGoto action_47
+action_105 (59) = happyGoto action_48
+action_105 (61) = happyGoto action_49
+action_105 (62) = happyGoto action_50
+action_105 (63) = happyGoto action_51
+action_105 (85) = happyGoto action_52
+action_105 _ = happyFail
+
+action_106 (93) = happyShift action_115
+action_106 _ = happyFail
+
+action_107 (141) = happyShift action_27
+action_107 (60) = happyGoto action_113
+action_107 (89) = happyGoto action_114
+action_107 _ = happyFail
+
+action_108 (98) = happyShift action_53
+action_108 (118) = happyShift action_54
+action_108 (119) = happyShift action_55
+action_108 (120) = happyShift action_56
+action_108 (121) = happyShift action_57
+action_108 (122) = happyShift action_58
+action_108 (123) = happyShift action_59
+action_108 (124) = happyShift action_60
+action_108 (125) = happyShift action_19
+action_108 (126) = happyShift action_20
+action_108 (130) = happyShift action_21
+action_108 (141) = happyShift action_61
+action_108 (146) = happyShift action_62
+action_108 (147) = happyShift action_63
+action_108 (148) = happyShift action_64
+action_108 (149) = happyShift action_65
+action_108 (150) = happyShift action_66
+action_108 (151) = happyShift action_67
+action_108 (153) = happyShift action_68
+action_108 (15) = happyGoto action_31
+action_108 (33) = happyGoto action_109
+action_108 (34) = happyGoto action_34
+action_108 (35) = happyGoto action_35
+action_108 (36) = happyGoto action_36
+action_108 (37) = happyGoto action_37
+action_108 (41) = happyGoto action_38
+action_108 (42) = happyGoto action_39
+action_108 (43) = happyGoto action_40
+action_108 (44) = happyGoto action_41
+action_108 (45) = happyGoto action_42
+action_108 (46) = happyGoto action_43
+action_108 (47) = happyGoto action_44
+action_108 (48) = happyGoto action_45
+action_108 (49) = happyGoto action_46
+action_108 (51) = happyGoto action_110
+action_108 (52) = happyGoto action_47
+action_108 (59) = happyGoto action_48
+action_108 (61) = happyGoto action_49
+action_108 (62) = happyGoto action_50
+action_108 (63) = happyGoto action_51
+action_108 (71) = happyGoto action_111
+action_108 (72) = happyGoto action_112
+action_108 (85) = happyGoto action_52
+action_108 _ = happyReduce_144
+
+action_109 (141) = happyShift action_27
+action_109 (38) = happyGoto action_205
+action_109 (40) = happyGoto action_103
+action_109 (89) = happyGoto action_104
+action_109 _ = happyFail
+
+action_110 _ = happyReduce_146
+
+action_111 (96) = happyShift action_204
+action_111 _ = happyFail
+
+action_112 (98) = happyShift action_53
+action_112 (118) = happyShift action_54
+action_112 (119) = happyShift action_55
+action_112 (120) = happyShift action_56
+action_112 (121) = happyShift action_57
+action_112 (122) = happyShift action_58
+action_112 (123) = happyShift action_59
+action_112 (124) = happyShift action_60
+action_112 (125) = happyShift action_19
+action_112 (126) = happyShift action_20
+action_112 (130) = happyShift action_21
+action_112 (141) = happyShift action_61
+action_112 (146) = happyShift action_62
+action_112 (147) = happyShift action_63
+action_112 (148) = happyShift action_64
+action_112 (149) = happyShift action_65
+action_112 (150) = happyShift action_66
+action_112 (151) = happyShift action_67
+action_112 (153) = happyShift action_68
+action_112 (15) = happyGoto action_31
+action_112 (33) = happyGoto action_109
+action_112 (34) = happyGoto action_34
+action_112 (35) = happyGoto action_35
+action_112 (36) = happyGoto action_36
+action_112 (37) = happyGoto action_37
+action_112 (41) = happyGoto action_38
+action_112 (42) = happyGoto action_39
+action_112 (43) = happyGoto action_40
+action_112 (44) = happyGoto action_41
+action_112 (45) = happyGoto action_42
+action_112 (46) = happyGoto action_43
+action_112 (47) = happyGoto action_44
+action_112 (48) = happyGoto action_45
+action_112 (49) = happyGoto action_46
+action_112 (51) = happyGoto action_203
+action_112 (52) = happyGoto action_47
+action_112 (59) = happyGoto action_48
+action_112 (61) = happyGoto action_49
+action_112 (62) = happyGoto action_50
+action_112 (63) = happyGoto action_51
+action_112 (85) = happyGoto action_52
+action_112 _ = happyReduce_145
+
+action_113 (96) = happyShift action_201
+action_113 (99) = happyShift action_202
+action_113 _ = happyFail
+
+action_114 _ = happyReduce_126
+
+action_115 (98) = happyShift action_53
+action_115 (119) = happyShift action_55
+action_115 (120) = happyShift action_56
+action_115 (121) = happyShift action_57
+action_115 (122) = happyShift action_58
+action_115 (124) = happyShift action_60
+action_115 (130) = happyShift action_21
+action_115 (141) = happyShift action_61
+action_115 (15) = happyGoto action_195
+action_115 (42) = happyGoto action_196
+action_115 (43) = happyGoto action_197
+action_115 (45) = happyGoto action_198
+action_115 (53) = happyGoto action_199
+action_115 (59) = happyGoto action_200
+action_115 _ = happyFail
+
+action_116 (96) = happyShift action_194
+action_116 (98) = happyShift action_53
+action_116 (118) = happyShift action_54
+action_116 (119) = happyShift action_55
+action_116 (120) = happyShift action_56
+action_116 (121) = happyShift action_57
+action_116 (122) = happyShift action_58
+action_116 (123) = happyShift action_59
+action_116 (124) = happyShift action_60
+action_116 (125) = happyShift action_19
+action_116 (126) = happyShift action_20
+action_116 (130) = happyShift action_21
+action_116 (141) = happyShift action_61
+action_116 (146) = happyShift action_62
+action_116 (147) = happyShift action_63
+action_116 (148) = happyShift action_64
+action_116 (149) = happyShift action_65
+action_116 (150) = happyShift action_66
+action_116 (151) = happyShift action_67
+action_116 (153) = happyShift action_68
+action_116 (15) = happyGoto action_31
+action_116 (33) = happyGoto action_109
+action_116 (34) = happyGoto action_34
+action_116 (35) = happyGoto action_35
+action_116 (36) = happyGoto action_36
+action_116 (37) = happyGoto action_37
+action_116 (41) = happyGoto action_38
+action_116 (42) = happyGoto action_39
+action_116 (43) = happyGoto action_40
+action_116 (44) = happyGoto action_41
+action_116 (45) = happyGoto action_42
+action_116 (46) = happyGoto action_43
+action_116 (47) = happyGoto action_44
+action_116 (48) = happyGoto action_45
+action_116 (49) = happyGoto action_46
+action_116 (51) = happyGoto action_193
+action_116 (52) = happyGoto action_47
+action_116 (59) = happyGoto action_48
+action_116 (61) = happyGoto action_49
+action_116 (62) = happyGoto action_50
+action_116 (63) = happyGoto action_51
+action_116 (85) = happyGoto action_52
+action_116 _ = happyFail
+
+action_117 _ = happyReduce_108
+
+action_118 (135) = happyShift action_120
+action_118 (66) = happyGoto action_192
+action_118 _ = happyReduce_96
+
+action_119 _ = happyReduce_135
+
+action_120 (98) = happyShift action_53
+action_120 (113) = happyShift action_135
+action_120 (139) = happyShift action_136
+action_120 (141) = happyShift action_61
+action_120 (143) = happyShift action_137
+action_120 (145) = happyShift action_138
+action_120 (15) = happyGoto action_122
+action_120 (19) = happyGoto action_123
+action_120 (20) = happyGoto action_124
+action_120 (21) = happyGoto action_125
+action_120 (22) = happyGoto action_126
+action_120 (23) = happyGoto action_127
+action_120 (24) = happyGoto action_128
+action_120 (25) = happyGoto action_129
+action_120 (26) = happyGoto action_130
+action_120 (27) = happyGoto action_131
+action_120 (28) = happyGoto action_132
+action_120 (29) = happyGoto action_133
+action_120 (30) = happyGoto action_191
+action_120 _ = happyFail
+
+action_121 (141) = happyShift action_27
+action_121 (40) = happyGoto action_190
+action_121 (89) = happyGoto action_104
+action_121 _ = happyFail
+
+action_122 (98) = happyShift action_94
+action_122 _ = happyReduce_63
+
+action_123 _ = happyReduce_66
+
+action_124 (105) = happyShift action_189
+action_124 _ = happyReduce_42
+
+action_125 (107) = happyShift action_188
+action_125 _ = happyReduce_43
+
+action_126 (108) = happyShift action_187
+action_126 _ = happyReduce_45
+
+action_127 (110) = happyShift action_186
+action_127 _ = happyReduce_47
+
+action_128 (143) = happyShift action_184
+action_128 (145) = happyShift action_185
+action_128 _ = happyReduce_49
+
+action_129 (111) = happyShift action_181
+action_129 (112) = happyShift action_182
+action_129 (144) = happyShift action_183
+action_129 _ = happyReduce_51
+
+action_130 _ = happyReduce_54
+
+action_131 (98) = happyShift action_53
+action_131 (139) = happyShift action_136
+action_131 (141) = happyShift action_61
+action_131 (15) = happyGoto action_122
+action_131 (28) = happyGoto action_180
+action_131 (29) = happyGoto action_133
+action_131 _ = happyFail
+
+action_132 _ = happyReduce_59
+
+action_133 _ = happyReduce_64
+
+action_134 (133) = happyShift action_179
+action_134 _ = happyFail
+
+action_135 _ = happyReduce_62
+
+action_136 _ = happyReduce_65
+
+action_137 _ = happyReduce_61
+
+action_138 _ = happyReduce_60
+
+action_139 (133) = happyShift action_178
+action_139 _ = happyFail
+
+action_140 (99) = happyShift action_176
+action_140 (133) = happyShift action_177
+action_140 _ = happyFail
+
+action_141 (99) = happyShift action_175
+action_141 _ = happyFail
+
+action_142 _ = happyReduce_29
+
+action_143 (98) = happyShift action_53
+action_143 (113) = happyShift action_135
+action_143 (139) = happyShift action_136
+action_143 (141) = happyShift action_61
+action_143 (143) = happyShift action_137
+action_143 (145) = happyShift action_138
+action_143 (15) = happyGoto action_122
+action_143 (19) = happyGoto action_174
+action_143 (20) = happyGoto action_124
+action_143 (21) = happyGoto action_125
+action_143 (22) = happyGoto action_126
+action_143 (23) = happyGoto action_127
+action_143 (24) = happyGoto action_128
+action_143 (25) = happyGoto action_129
+action_143 (26) = happyGoto action_130
+action_143 (27) = happyGoto action_131
+action_143 (28) = happyGoto action_132
+action_143 (29) = happyGoto action_133
+action_143 _ = happyFail
+
+action_144 (98) = happyShift action_94
+action_144 (99) = happyShift action_173
+action_144 (16) = happyGoto action_172
+action_144 _ = happyReduce_30
+
+action_145 (91) = happyShift action_15
+action_145 (92) = happyShift action_16
+action_145 (96) = happyShift action_171
+action_145 (101) = happyShift action_17
+action_145 (116) = happyShift action_18
+action_145 (125) = happyShift action_19
+action_145 (126) = happyShift action_20
+action_145 (130) = happyShift action_21
+action_145 (154) = happyShift action_22
+action_145 (158) = happyShift action_23
+action_145 (159) = happyShift action_24
+action_145 (160) = happyShift action_25
+action_145 (6) = happyGoto action_4
+action_145 (7) = happyGoto action_5
+action_145 (8) = happyGoto action_6
+action_145 (9) = happyGoto action_7
+action_145 (10) = happyGoto action_8
+action_145 (17) = happyGoto action_9
+action_145 (31) = happyGoto action_10
+action_145 (49) = happyGoto action_11
+action_145 (52) = happyGoto action_12
+action_145 (59) = happyGoto action_13
+action_145 (70) = happyGoto action_14
+action_145 _ = happyFail
+
+action_146 _ = happyReduce_18
+
+action_147 (90) = happyShift action_170
+action_147 _ = happyFail
+
+action_148 (90) = happyShift action_169
+action_148 _ = happyFail
+
+action_149 (90) = happyShift action_168
+action_149 _ = happyFail
+
+action_150 (142) = happyShift action_167
+action_150 _ = happyFail
+
+action_151 (90) = happyShift action_166
+action_151 _ = happyFail
+
+action_152 (90) = happyShift action_165
+action_152 _ = happyFail
+
+action_153 (98) = happyShift action_53
+action_153 (118) = happyShift action_54
+action_153 (119) = happyShift action_55
+action_153 (120) = happyShift action_56
+action_153 (121) = happyShift action_57
+action_153 (122) = happyShift action_58
+action_153 (123) = happyShift action_59
+action_153 (124) = happyShift action_60
+action_153 (137) = happyShift action_164
+action_153 (141) = happyShift action_61
+action_153 (146) = happyShift action_62
+action_153 (147) = happyShift action_63
+action_153 (149) = happyShift action_65
+action_153 (150) = happyShift action_66
+action_153 (151) = happyShift action_67
+action_153 (153) = happyShift action_68
+action_153 (15) = happyGoto action_157
+action_153 (35) = happyGoto action_158
+action_153 (41) = happyGoto action_38
+action_153 (42) = happyGoto action_39
+action_153 (43) = happyGoto action_40
+action_153 (44) = happyGoto action_41
+action_153 (45) = happyGoto action_42
+action_153 (46) = happyGoto action_43
+action_153 (47) = happyGoto action_44
+action_153 (48) = happyGoto action_45
+action_153 (62) = happyGoto action_159
+action_153 (63) = happyGoto action_160
+action_153 (75) = happyGoto action_161
+action_153 (84) = happyGoto action_162
+action_153 (85) = happyGoto action_163
+action_153 _ = happyFail
+
+action_154 _ = happyReduce_15
+
+action_155 _ = happyReduce_150
+
+action_156 _ = happyReduce_139
+
+action_157 (98) = happyShift action_94
+action_157 _ = happyReduce_171
+
+action_158 _ = happyReduce_167
+
+action_159 _ = happyReduce_168
+
+action_160 _ = happyReduce_169
+
+action_161 (141) = happyShift action_27
+action_161 (89) = happyGoto action_224
+action_161 _ = happyFail
+
+action_162 _ = happyReduce_151
+
+action_163 _ = happyReduce_170
+
+action_164 _ = happyReduce_152
+
+action_165 _ = happyReduce_23
+
+action_166 _ = happyReduce_21
+
+action_167 (98) = happyShift action_53
+action_167 (118) = happyShift action_54
+action_167 (119) = happyShift action_55
+action_167 (120) = happyShift action_56
+action_167 (121) = happyShift action_57
+action_167 (122) = happyShift action_58
+action_167 (123) = happyShift action_59
+action_167 (124) = happyShift action_60
+action_167 (141) = happyShift action_61
+action_167 (146) = happyShift action_62
+action_167 (147) = happyShift action_63
+action_167 (149) = happyShift action_65
+action_167 (150) = happyShift action_66
+action_167 (151) = happyShift action_67
+action_167 (153) = happyShift action_68
+action_167 (15) = happyGoto action_157
+action_167 (35) = happyGoto action_158
+action_167 (41) = happyGoto action_38
+action_167 (42) = happyGoto action_39
+action_167 (43) = happyGoto action_40
+action_167 (44) = happyGoto action_41
+action_167 (45) = happyGoto action_42
+action_167 (46) = happyGoto action_43
+action_167 (47) = happyGoto action_44
+action_167 (48) = happyGoto action_45
+action_167 (62) = happyGoto action_159
+action_167 (63) = happyGoto action_160
+action_167 (84) = happyGoto action_223
+action_167 (85) = happyGoto action_163
+action_167 _ = happyFail
+
+action_168 _ = happyReduce_22
+
+action_169 _ = happyReduce_19
+
+action_170 _ = happyReduce_20
+
+action_171 _ = happyReduce_12
+
+action_172 _ = happyReduce_26
+
+action_173 (98) = happyShift action_53
+action_173 (141) = happyShift action_61
+action_173 (15) = happyGoto action_222
+action_173 _ = happyFail
+
+action_174 _ = happyReduce_32
+
+action_175 (139) = happyShift action_221
+action_175 (87) = happyGoto action_220
+action_175 _ = happyFail
+
+action_176 (98) = happyShift action_53
+action_176 (113) = happyShift action_135
+action_176 (139) = happyShift action_136
+action_176 (141) = happyShift action_61
+action_176 (143) = happyShift action_137
+action_176 (145) = happyShift action_138
+action_176 (15) = happyGoto action_122
+action_176 (19) = happyGoto action_123
+action_176 (20) = happyGoto action_124
+action_176 (21) = happyGoto action_125
+action_176 (22) = happyGoto action_126
+action_176 (23) = happyGoto action_127
+action_176 (24) = happyGoto action_128
+action_176 (25) = happyGoto action_129
+action_176 (26) = happyGoto action_130
+action_176 (27) = happyGoto action_131
+action_176 (28) = happyGoto action_132
+action_176 (29) = happyGoto action_133
+action_176 (30) = happyGoto action_219
+action_176 _ = happyFail
+
+action_177 _ = happyReduce_129
+
+action_178 _ = happyReduce_132
+
+action_179 _ = happyReduce_130
+
+action_180 _ = happyReduce_58
+
+action_181 (98) = happyShift action_53
+action_181 (113) = happyShift action_135
+action_181 (139) = happyShift action_136
+action_181 (141) = happyShift action_61
+action_181 (143) = happyShift action_137
+action_181 (145) = happyShift action_138
+action_181 (15) = happyGoto action_122
+action_181 (26) = happyGoto action_218
+action_181 (27) = happyGoto action_131
+action_181 (28) = happyGoto action_132
+action_181 (29) = happyGoto action_133
+action_181 _ = happyFail
+
+action_182 (98) = happyShift action_53
+action_182 (113) = happyShift action_135
+action_182 (139) = happyShift action_136
+action_182 (141) = happyShift action_61
+action_182 (143) = happyShift action_137
+action_182 (145) = happyShift action_138
+action_182 (15) = happyGoto action_122
+action_182 (26) = happyGoto action_217
+action_182 (27) = happyGoto action_131
+action_182 (28) = happyGoto action_132
+action_182 (29) = happyGoto action_133
+action_182 _ = happyFail
+
+action_183 (98) = happyShift action_53
+action_183 (113) = happyShift action_135
+action_183 (139) = happyShift action_136
+action_183 (141) = happyShift action_61
+action_183 (143) = happyShift action_137
+action_183 (145) = happyShift action_138
+action_183 (15) = happyGoto action_122
+action_183 (26) = happyGoto action_216
+action_183 (27) = happyGoto action_131
+action_183 (28) = happyGoto action_132
+action_183 (29) = happyGoto action_133
+action_183 _ = happyFail
+
+action_184 (98) = happyShift action_53
+action_184 (113) = happyShift action_135
+action_184 (139) = happyShift action_136
+action_184 (141) = happyShift action_61
+action_184 (143) = happyShift action_137
+action_184 (145) = happyShift action_138
+action_184 (15) = happyGoto action_122
+action_184 (25) = happyGoto action_215
+action_184 (26) = happyGoto action_130
+action_184 (27) = happyGoto action_131
+action_184 (28) = happyGoto action_132
+action_184 (29) = happyGoto action_133
+action_184 _ = happyFail
+
+action_185 (98) = happyShift action_53
+action_185 (113) = happyShift action_135
+action_185 (139) = happyShift action_136
+action_185 (141) = happyShift action_61
+action_185 (143) = happyShift action_137
+action_185 (145) = happyShift action_138
+action_185 (15) = happyGoto action_122
+action_185 (25) = happyGoto action_214
+action_185 (26) = happyGoto action_130
+action_185 (27) = happyGoto action_131
+action_185 (28) = happyGoto action_132
+action_185 (29) = happyGoto action_133
+action_185 _ = happyFail
+
+action_186 (98) = happyShift action_53
+action_186 (113) = happyShift action_135
+action_186 (139) = happyShift action_136
+action_186 (141) = happyShift action_61
+action_186 (143) = happyShift action_137
+action_186 (145) = happyShift action_138
+action_186 (15) = happyGoto action_122
+action_186 (24) = happyGoto action_213
+action_186 (25) = happyGoto action_129
+action_186 (26) = happyGoto action_130
+action_186 (27) = happyGoto action_131
+action_186 (28) = happyGoto action_132
+action_186 (29) = happyGoto action_133
+action_186 _ = happyFail
+
+action_187 (98) = happyShift action_53
+action_187 (113) = happyShift action_135
+action_187 (139) = happyShift action_136
+action_187 (141) = happyShift action_61
+action_187 (143) = happyShift action_137
+action_187 (145) = happyShift action_138
+action_187 (15) = happyGoto action_122
+action_187 (23) = happyGoto action_212
+action_187 (24) = happyGoto action_128
+action_187 (25) = happyGoto action_129
+action_187 (26) = happyGoto action_130
+action_187 (27) = happyGoto action_131
+action_187 (28) = happyGoto action_132
+action_187 (29) = happyGoto action_133
+action_187 _ = happyFail
+
+action_188 (98) = happyShift action_53
+action_188 (113) = happyShift action_135
+action_188 (139) = happyShift action_136
+action_188 (141) = happyShift action_61
+action_188 (143) = happyShift action_137
+action_188 (145) = happyShift action_138
+action_188 (15) = happyGoto action_122
+action_188 (22) = happyGoto action_211
+action_188 (23) = happyGoto action_127
+action_188 (24) = happyGoto action_128
+action_188 (25) = happyGoto action_129
+action_188 (26) = happyGoto action_130
+action_188 (27) = happyGoto action_131
+action_188 (28) = happyGoto action_132
+action_188 (29) = happyGoto action_133
+action_188 _ = happyFail
+
+action_189 (98) = happyShift action_53
+action_189 (113) = happyShift action_135
+action_189 (139) = happyShift action_136
+action_189 (141) = happyShift action_61
+action_189 (143) = happyShift action_137
+action_189 (145) = happyShift action_138
+action_189 (15) = happyGoto action_122
+action_189 (21) = happyGoto action_210
+action_189 (22) = happyGoto action_126
+action_189 (23) = happyGoto action_127
+action_189 (24) = happyGoto action_128
+action_189 (25) = happyGoto action_129
+action_189 (26) = happyGoto action_130
+action_189 (27) = happyGoto action_131
+action_189 (28) = happyGoto action_132
+action_189 (29) = happyGoto action_133
+action_189 _ = happyFail
+
+action_190 _ = happyReduce_93
+
+action_191 (136) = happyShift action_209
+action_191 _ = happyFail
+
+action_192 _ = happyReduce_136
+
+action_193 _ = happyReduce_109
+
+action_194 _ = happyReduce_107
+
+action_195 (98) = happyShift action_94
+action_195 _ = happyReduce_116
+
+action_196 _ = happyReduce_112
+
+action_197 _ = happyReduce_113
+
+action_198 _ = happyReduce_114
+
+action_199 (94) = happyShift action_208
+action_199 _ = happyFail
+
+action_200 _ = happyReduce_115
+
+action_201 _ = happyReduce_125
+
+action_202 (141) = happyShift action_27
+action_202 (89) = happyGoto action_207
+action_202 _ = happyFail
+
+action_203 _ = happyReduce_147
+
+action_204 _ = happyReduce_143
+
+action_205 (90) = happyShift action_206
+action_205 (99) = happyShift action_121
+action_205 _ = happyFail
+
+action_206 _ = happyReduce_110
+
+action_207 _ = happyReduce_127
+
+action_208 (95) = happyShift action_233
+action_208 _ = happyFail
+
+action_209 _ = happyReduce_137
+
+action_210 (107) = happyShift action_188
+action_210 _ = happyReduce_44
+
+action_211 (108) = happyShift action_187
+action_211 _ = happyReduce_46
+
+action_212 (110) = happyShift action_186
+action_212 _ = happyReduce_48
+
+action_213 (143) = happyShift action_184
+action_213 (145) = happyShift action_185
+action_213 _ = happyReduce_50
+
+action_214 (111) = happyShift action_181
+action_214 (112) = happyShift action_182
+action_214 (144) = happyShift action_183
+action_214 _ = happyReduce_53
+
+action_215 (111) = happyShift action_181
+action_215 (112) = happyShift action_182
+action_215 (144) = happyShift action_183
+action_215 _ = happyReduce_52
+
+action_216 _ = happyReduce_55
+
+action_217 _ = happyReduce_57
+
+action_218 _ = happyReduce_56
+
+action_219 (133) = happyShift action_232
+action_219 _ = happyFail
+
+action_220 (133) = happyShift action_231
+action_220 _ = happyFail
+
+action_221 _ = happyReduce_174
+
+action_222 (98) = happyShift action_94
+action_222 (99) = happyShift action_173
+action_222 (16) = happyGoto action_230
+action_222 _ = happyReduce_30
+
+action_223 (141) = happyShift action_27
+action_223 (39) = happyGoto action_227
+action_223 (69) = happyGoto action_228
+action_223 (89) = happyGoto action_229
+action_223 _ = happyFail
+
+action_224 (93) = happyShift action_226
+action_224 (76) = happyGoto action_225
+action_224 _ = happyFail
+
+action_225 (155) = happyShift action_247
+action_225 (80) = happyGoto action_246
+action_225 _ = happyReduce_159
+
+action_226 (94) = happyShift action_244
+action_226 (138) = happyShift action_245
+action_226 (77) = happyGoto action_241
+action_226 (78) = happyGoto action_242
+action_226 (79) = happyGoto action_243
+action_226 _ = happyFail
+
+action_227 _ = happyReduce_141
+
+action_228 (99) = happyShift action_240
+action_228 _ = happyReduce_138
+
+action_229 _ = happyReduce_94
+
+action_230 _ = happyReduce_31
+
+action_231 _ = happyReduce_172
+
+action_232 _ = happyReduce_128
+
+action_233 (128) = happyShift action_238
+action_233 (129) = happyShift action_239
+action_233 (54) = happyGoto action_234
+action_233 (55) = happyGoto action_235
+action_233 (56) = happyGoto action_236
+action_233 (57) = happyGoto action_237
+action_233 _ = happyFail
+
+action_234 (96) = happyShift action_261
+action_234 (128) = happyShift action_238
+action_234 (129) = happyShift action_239
+action_234 (55) = happyGoto action_260
+action_234 (56) = happyGoto action_236
+action_234 (57) = happyGoto action_237
+action_234 _ = happyFail
+
+action_235 _ = happyReduce_117
+
+action_236 (98) = happyShift action_53
+action_236 (118) = happyShift action_54
+action_236 (119) = happyShift action_55
+action_236 (120) = happyShift action_56
+action_236 (121) = happyShift action_57
+action_236 (122) = happyShift action_58
+action_236 (123) = happyShift action_59
+action_236 (124) = happyShift action_60
+action_236 (125) = happyShift action_19
+action_236 (126) = happyShift action_20
+action_236 (128) = happyShift action_238
+action_236 (129) = happyShift action_239
+action_236 (130) = happyShift action_21
+action_236 (141) = happyShift action_61
+action_236 (146) = happyShift action_62
+action_236 (147) = happyShift action_63
+action_236 (148) = happyShift action_64
+action_236 (149) = happyShift action_65
+action_236 (150) = happyShift action_66
+action_236 (151) = happyShift action_67
+action_236 (153) = happyShift action_68
+action_236 (15) = happyGoto action_31
+action_236 (33) = happyGoto action_257
+action_236 (34) = happyGoto action_34
+action_236 (35) = happyGoto action_35
+action_236 (36) = happyGoto action_36
+action_236 (37) = happyGoto action_37
+action_236 (41) = happyGoto action_38
+action_236 (42) = happyGoto action_39
+action_236 (43) = happyGoto action_40
+action_236 (44) = happyGoto action_41
+action_236 (45) = happyGoto action_42
+action_236 (46) = happyGoto action_43
+action_236 (47) = happyGoto action_44
+action_236 (48) = happyGoto action_45
+action_236 (49) = happyGoto action_46
+action_236 (52) = happyGoto action_47
+action_236 (57) = happyGoto action_258
+action_236 (58) = happyGoto action_259
+action_236 (59) = happyGoto action_48
+action_236 (61) = happyGoto action_49
+action_236 (62) = happyGoto action_50
+action_236 (63) = happyGoto action_51
+action_236 (85) = happyGoto action_52
+action_236 _ = happyFail
+
+action_237 _ = happyReduce_120
+
+action_238 (98) = happyShift action_53
+action_238 (113) = happyShift action_135
+action_238 (139) = happyShift action_136
+action_238 (141) = happyShift action_61
+action_238 (143) = happyShift action_137
+action_238 (145) = happyShift action_138
+action_238 (15) = happyGoto action_122
+action_238 (19) = happyGoto action_256
+action_238 (20) = happyGoto action_124
+action_238 (21) = happyGoto action_125
+action_238 (22) = happyGoto action_126
+action_238 (23) = happyGoto action_127
+action_238 (24) = happyGoto action_128
+action_238 (25) = happyGoto action_129
+action_238 (26) = happyGoto action_130
+action_238 (27) = happyGoto action_131
+action_238 (28) = happyGoto action_132
+action_238 (29) = happyGoto action_133
+action_238 _ = happyFail
+
+action_239 (97) = happyShift action_255
+action_239 _ = happyFail
+
+action_240 (141) = happyShift action_27
+action_240 (39) = happyGoto action_254
+action_240 (89) = happyGoto action_229
+action_240 _ = happyFail
+
+action_241 (94) = happyShift action_252
+action_241 (99) = happyShift action_253
+action_241 _ = happyFail
+
+action_242 _ = happyReduce_155
+
+action_243 (98) = happyShift action_53
+action_243 (118) = happyShift action_54
+action_243 (119) = happyShift action_55
+action_243 (120) = happyShift action_56
+action_243 (121) = happyShift action_57
+action_243 (122) = happyShift action_58
+action_243 (123) = happyShift action_59
+action_243 (124) = happyShift action_60
+action_243 (141) = happyShift action_61
+action_243 (146) = happyShift action_62
+action_243 (147) = happyShift action_63
+action_243 (149) = happyShift action_65
+action_243 (150) = happyShift action_66
+action_243 (151) = happyShift action_67
+action_243 (153) = happyShift action_68
+action_243 (15) = happyGoto action_157
+action_243 (35) = happyGoto action_158
+action_243 (41) = happyGoto action_38
+action_243 (42) = happyGoto action_39
+action_243 (43) = happyGoto action_40
+action_243 (44) = happyGoto action_41
+action_243 (45) = happyGoto action_42
+action_243 (46) = happyGoto action_43
+action_243 (47) = happyGoto action_44
+action_243 (48) = happyGoto action_45
+action_243 (62) = happyGoto action_159
+action_243 (63) = happyGoto action_160
+action_243 (84) = happyGoto action_251
+action_243 (85) = happyGoto action_163
+action_243 _ = happyFail
+
+action_244 _ = happyReduce_154
+
+action_245 _ = happyReduce_158
+
+action_246 (156) = happyShift action_250
+action_246 (81) = happyGoto action_249
+action_246 _ = happyReduce_161
+
+action_247 (93) = happyShift action_248
+action_247 _ = happyFail
+
+action_248 (98) = happyShift action_53
+action_248 (141) = happyShift action_61
+action_248 (15) = happyGoto action_268
+action_248 (82) = happyGoto action_269
+action_248 _ = happyFail
+
+action_249 _ = happyReduce_148
+
+action_250 (93) = happyShift action_267
+action_250 _ = happyFail
+
+action_251 (141) = happyShift action_27
+action_251 (39) = happyGoto action_266
+action_251 (89) = happyGoto action_229
+action_251 _ = happyFail
+
+action_252 _ = happyReduce_153
+
+action_253 (138) = happyShift action_245
+action_253 (78) = happyGoto action_265
+action_253 (79) = happyGoto action_243
+action_253 _ = happyFail
+
+action_254 _ = happyReduce_142
+
+action_255 _ = happyReduce_123
+
+action_256 (97) = happyShift action_264
+action_256 _ = happyFail
+
+action_257 (141) = happyShift action_27
+action_257 (40) = happyGoto action_263
+action_257 (89) = happyGoto action_104
+action_257 _ = happyFail
+
+action_258 _ = happyReduce_121
+
+action_259 (90) = happyShift action_262
+action_259 _ = happyFail
+
+action_260 _ = happyReduce_118
+
+action_261 _ = happyReduce_111
+
+action_262 _ = happyReduce_119
+
+action_263 _ = happyReduce_124
+
+action_264 _ = happyReduce_122
+
+action_265 _ = happyReduce_156
+
+action_266 _ = happyReduce_157
+
+action_267 (140) = happyShift action_273
+action_267 (83) = happyGoto action_272
+action_267 _ = happyFail
+
+action_268 (98) = happyShift action_94
+action_268 _ = happyReduce_163
+
+action_269 (94) = happyShift action_270
+action_269 (99) = happyShift action_271
+action_269 _ = happyFail
+
+action_270 _ = happyReduce_160
+
+action_271 (98) = happyShift action_53
+action_271 (141) = happyShift action_61
+action_271 (15) = happyGoto action_276
+action_271 _ = happyFail
+
+action_272 (94) = happyShift action_274
+action_272 (99) = happyShift action_275
+action_272 _ = happyFail
+
+action_273 _ = happyReduce_165
+
+action_274 _ = happyReduce_162
+
+action_275 (140) = happyShift action_277
+action_275 _ = happyFail
+
+action_276 (98) = happyShift action_94
+action_276 _ = happyReduce_164
+
+action_277 _ = happyReduce_166
+
+happyReduce_1 = happySpecReduce_1 4 happyReduction_1
+happyReduction_1 (HappyAbsSyn4  happy_var_1)
+	 =  HappyAbsSyn4
+		 ((reverse happy_var_1)
+	)
+happyReduction_1 _  = notHappyAtAll 
+
+happyReduce_2 = happySpecReduce_0 5 happyReduction_2
+happyReduction_2  =  HappyAbsSyn4
+		 ([]
+	)
+
+happyReduce_3 = happySpecReduce_2 5 happyReduction_3
+happyReduction_3 (HappyAbsSyn6  happy_var_2)
+	(HappyAbsSyn4  happy_var_1)
+	 =  HappyAbsSyn4
+		 (happy_var_2 : happy_var_1
+	)
+happyReduction_3 _ _  = notHappyAtAll 
+
+happyReduce_4 = happySpecReduce_2 6 happyReduction_4
+happyReduction_4 _
+	(HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_1
+	)
+happyReduction_4 _ _  = notHappyAtAll 
+
+happyReduce_5 = happySpecReduce_2 6 happyReduction_5
+happyReduction_5 _
+	(HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_1
+	)
+happyReduction_5 _ _  = notHappyAtAll 
+
+happyReduce_6 = happySpecReduce_2 6 happyReduction_6
+happyReduction_6 _
+	(HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_1
+	)
+happyReduction_6 _ _  = notHappyAtAll 
+
+happyReduce_7 = happySpecReduce_2 6 happyReduction_7
+happyReduction_7 _
+	(HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_1
+	)
+happyReduction_7 _ _  = notHappyAtAll 
+
+happyReduce_8 = happySpecReduce_2 6 happyReduction_8
+happyReduction_8 _
+	(HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_1
+	)
+happyReduction_8 _ _  = notHappyAtAll 
+
+happyReduce_9 = happySpecReduce_1 6 happyReduction_9
+happyReduction_9 (HappyTerminal (T_pragma happy_var_1))
+	 =  HappyAbsSyn6
+		 (Pragma happy_var_1
+	)
+happyReduction_9 _  = notHappyAtAll 
+
+happyReduce_10 = happySpecReduce_1 6 happyReduction_10
+happyReduction_10 (HappyTerminal (T_include_start happy_var_1))
+	 =  HappyAbsSyn6
+		 (IncludeStart happy_var_1
+	)
+happyReduction_10 _  = notHappyAtAll 
+
+happyReduce_11 = happySpecReduce_1 6 happyReduction_11
+happyReduction_11 _
+	 =  HappyAbsSyn6
+		 (IncludeEnd
+	)
+
+happyReduce_12 = happyReduce 5 7 happyReduction_12
+happyReduction_12 (_ `HappyStk`
+	(HappyAbsSyn4  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn39  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn6
+		 (Module happy_var_2 (reverse happy_var_4)
+	) `HappyStk` happyRest
+
+happyReduce_13 = happySpecReduce_1 8 happyReduction_13
+happyReduction_13 (HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_1
+	)
+happyReduction_13 _  = notHappyAtAll 
+
+happyReduce_14 = happySpecReduce_2 8 happyReduction_14
+happyReduction_14 (HappyAbsSyn39  happy_var_2)
+	_
+	 =  HappyAbsSyn6
+		 (Forward happy_var_2
+	)
+happyReduction_14 _ _  = notHappyAtAll 
+
+happyReduce_15 = happyReduce 4 9 happyReduction_15
+happyReduction_15 (_ `HappyStk`
+	(HappyAbsSyn4  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn10  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn6
+		 (let (ids,inherit) = happy_var_1 in Interface ids inherit (reverse happy_var_3)
+	) `HappyStk` happyRest
+
+happyReduce_16 = happySpecReduce_3 10 happyReduction_16
+happyReduction_16 (HappyAbsSyn13  happy_var_3)
+	(HappyAbsSyn39  happy_var_2)
+	_
+	 =  HappyAbsSyn10
+		 ((happy_var_2,happy_var_3)
+	)
+happyReduction_16 _ _ _  = notHappyAtAll 
+
+happyReduce_17 = happySpecReduce_0 11 happyReduction_17
+happyReduction_17  =  HappyAbsSyn4
+		 ([]
+	)
+
+happyReduce_18 = happySpecReduce_2 11 happyReduction_18
+happyReduction_18 (HappyAbsSyn6  happy_var_2)
+	(HappyAbsSyn4  happy_var_1)
+	 =  HappyAbsSyn4
+		 (happy_var_2 : happy_var_1
+	)
+happyReduction_18 _ _  = notHappyAtAll 
+
+happyReduce_19 = happySpecReduce_2 12 happyReduction_19
+happyReduction_19 _
+	(HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_1
+	)
+happyReduction_19 _ _  = notHappyAtAll 
+
+happyReduce_20 = happySpecReduce_2 12 happyReduction_20
+happyReduction_20 _
+	(HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_1
+	)
+happyReduction_20 _ _  = notHappyAtAll 
+
+happyReduce_21 = happySpecReduce_2 12 happyReduction_21
+happyReduction_21 _
+	(HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_1
+	)
+happyReduction_21 _ _  = notHappyAtAll 
+
+happyReduce_22 = happySpecReduce_2 12 happyReduction_22
+happyReduction_22 _
+	(HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_1
+	)
+happyReduction_22 _ _  = notHappyAtAll 
+
+happyReduce_23 = happySpecReduce_2 12 happyReduction_23
+happyReduction_23 _
+	(HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_1
+	)
+happyReduction_23 _ _  = notHappyAtAll 
+
+happyReduce_24 = happySpecReduce_0 13 happyReduction_24
+happyReduction_24  =  HappyAbsSyn13
+		 ([]
+	)
+
+happyReduce_25 = happySpecReduce_1 13 happyReduction_25
+happyReduction_25 (HappyAbsSyn13  happy_var_1)
+	 =  HappyAbsSyn13
+		 (happy_var_1
+	)
+happyReduction_25 _  = notHappyAtAll 
+
+happyReduce_26 = happySpecReduce_3 14 happyReduction_26
+happyReduction_26 (HappyAbsSyn13  happy_var_3)
+	(HappyAbsSyn15  happy_var_2)
+	_
+	 =  HappyAbsSyn13
+		 (happy_var_2:(reverse happy_var_3)
+	)
+happyReduction_26 _ _ _  = notHappyAtAll 
+
+happyReduce_27 = happySpecReduce_1 15 happyReduction_27
+happyReduction_27 (HappyTerminal (T_id happy_var_1))
+	 =  HappyAbsSyn15
+		 (happy_var_1
+	)
+happyReduction_27 _  = notHappyAtAll 
+
+happyReduce_28 = happySpecReduce_2 15 happyReduction_28
+happyReduction_28 (HappyTerminal (T_id happy_var_2))
+	_
+	 =  HappyAbsSyn15
+		 (("::"++ happy_var_2)
+	)
+happyReduction_28 _ _  = notHappyAtAll 
+
+happyReduce_29 = happySpecReduce_3 15 happyReduction_29
+happyReduction_29 (HappyTerminal (T_id happy_var_3))
+	_
+	(HappyAbsSyn15  happy_var_1)
+	 =  HappyAbsSyn15
+		 (happy_var_1 ++ ':':':':happy_var_3
+	)
+happyReduction_29 _ _ _  = notHappyAtAll 
+
+happyReduce_30 = happySpecReduce_0 16 happyReduction_30
+happyReduction_30  =  HappyAbsSyn13
+		 ([]
+	)
+
+happyReduce_31 = happySpecReduce_3 16 happyReduction_31
+happyReduction_31 (HappyAbsSyn13  happy_var_3)
+	(HappyAbsSyn15  happy_var_2)
+	_
+	 =  HappyAbsSyn13
+		 (happy_var_2 : happy_var_3
+	)
+happyReduction_31 _ _ _  = notHappyAtAll 
+
+happyReduce_32 = happyReduce 5 17 happyReduction_32
+happyReduction_32 ((HappyAbsSyn19  happy_var_5) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn39  happy_var_3) `HappyStk`
+	(HappyAbsSyn18  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn6
+		 (Constant happy_var_3 [] happy_var_2 happy_var_5
+	) `HappyStk` happyRest
+
+happyReduce_33 = happySpecReduce_1 18 happyReduction_33
+happyReduction_33 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_33 _  = notHappyAtAll 
+
+happyReduce_34 = happySpecReduce_1 18 happyReduction_34
+happyReduction_34 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_34 _  = notHappyAtAll 
+
+happyReduce_35 = happySpecReduce_1 18 happyReduction_35
+happyReduction_35 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_35 _  = notHappyAtAll 
+
+happyReduce_36 = happySpecReduce_1 18 happyReduction_36
+happyReduction_36 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_36 _  = notHappyAtAll 
+
+happyReduce_37 = happySpecReduce_1 18 happyReduction_37
+happyReduction_37 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_37 _  = notHappyAtAll 
+
+happyReduce_38 = happySpecReduce_1 18 happyReduction_38
+happyReduction_38 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_38 _  = notHappyAtAll 
+
+happyReduce_39 = happySpecReduce_1 18 happyReduction_39
+happyReduction_39 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_39 _  = notHappyAtAll 
+
+happyReduce_40 = happySpecReduce_1 18 happyReduction_40
+happyReduction_40 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_40 _  = notHappyAtAll 
+
+happyReduce_41 = happySpecReduce_1 18 happyReduction_41
+happyReduction_41 (HappyAbsSyn15  happy_var_1)
+	 =  HappyAbsSyn18
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_41 _  = notHappyAtAll 
+
+happyReduce_42 = happySpecReduce_1 19 happyReduction_42
+happyReduction_42 (HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (happy_var_1
+	)
+happyReduction_42 _  = notHappyAtAll 
+
+happyReduce_43 = happySpecReduce_1 20 happyReduction_43
+happyReduction_43 (HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (happy_var_1
+	)
+happyReduction_43 _  = notHappyAtAll 
+
+happyReduce_44 = happySpecReduce_3 20 happyReduction_44
+happyReduction_44 (HappyAbsSyn19  happy_var_3)
+	_
+	(HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Binary Or happy_var_1 happy_var_3
+	)
+happyReduction_44 _ _ _  = notHappyAtAll 
+
+happyReduce_45 = happySpecReduce_1 21 happyReduction_45
+happyReduction_45 (HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (happy_var_1
+	)
+happyReduction_45 _  = notHappyAtAll 
+
+happyReduce_46 = happySpecReduce_3 21 happyReduction_46
+happyReduction_46 (HappyAbsSyn19  happy_var_3)
+	_
+	(HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Binary Xor happy_var_1 happy_var_3
+	)
+happyReduction_46 _ _ _  = notHappyAtAll 
+
+happyReduce_47 = happySpecReduce_1 22 happyReduction_47
+happyReduction_47 (HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (happy_var_1
+	)
+happyReduction_47 _  = notHappyAtAll 
+
+happyReduce_48 = happySpecReduce_3 22 happyReduction_48
+happyReduction_48 (HappyAbsSyn19  happy_var_3)
+	_
+	(HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Binary And happy_var_1 happy_var_3
+	)
+happyReduction_48 _ _ _  = notHappyAtAll 
+
+happyReduce_49 = happySpecReduce_1 23 happyReduction_49
+happyReduction_49 (HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (happy_var_1
+	)
+happyReduction_49 _  = notHappyAtAll 
+
+happyReduce_50 = happySpecReduce_3 23 happyReduction_50
+happyReduction_50 (HappyAbsSyn19  happy_var_3)
+	(HappyTerminal (T_shift happy_var_2))
+	(HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Binary (Shift happy_var_2) happy_var_1 happy_var_3
+	)
+happyReduction_50 _ _ _  = notHappyAtAll 
+
+happyReduce_51 = happySpecReduce_1 24 happyReduction_51
+happyReduction_51 (HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (happy_var_1
+	)
+happyReduction_51 _  = notHappyAtAll 
+
+happyReduce_52 = happySpecReduce_3 24 happyReduction_52
+happyReduction_52 (HappyAbsSyn19  happy_var_3)
+	_
+	(HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Binary Add happy_var_1 happy_var_3
+	)
+happyReduction_52 _ _ _  = notHappyAtAll 
+
+happyReduce_53 = happySpecReduce_3 24 happyReduction_53
+happyReduction_53 (HappyAbsSyn19  happy_var_3)
+	_
+	(HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Binary Sub happy_var_1 happy_var_3
+	)
+happyReduction_53 _ _ _  = notHappyAtAll 
+
+happyReduce_54 = happySpecReduce_1 25 happyReduction_54
+happyReduction_54 (HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (happy_var_1
+	)
+happyReduction_54 _  = notHappyAtAll 
+
+happyReduce_55 = happySpecReduce_3 25 happyReduction_55
+happyReduction_55 (HappyAbsSyn19  happy_var_3)
+	_
+	(HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Binary Mul happy_var_1 happy_var_3
+	)
+happyReduction_55 _ _ _  = notHappyAtAll 
+
+happyReduce_56 = happySpecReduce_3 25 happyReduction_56
+happyReduction_56 (HappyAbsSyn19  happy_var_3)
+	_
+	(HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Binary Div happy_var_1 happy_var_3
+	)
+happyReduction_56 _ _ _  = notHappyAtAll 
+
+happyReduce_57 = happySpecReduce_3 25 happyReduction_57
+happyReduction_57 (HappyAbsSyn19  happy_var_3)
+	_
+	(HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Binary Mod happy_var_1 happy_var_3
+	)
+happyReduction_57 _ _ _  = notHappyAtAll 
+
+happyReduce_58 = happySpecReduce_2 26 happyReduction_58
+happyReduction_58 (HappyAbsSyn19  happy_var_2)
+	(HappyAbsSyn27  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Unary happy_var_1 happy_var_2
+	)
+happyReduction_58 _ _  = notHappyAtAll 
+
+happyReduce_59 = happySpecReduce_1 26 happyReduction_59
+happyReduction_59 (HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (happy_var_1
+	)
+happyReduction_59 _  = notHappyAtAll 
+
+happyReduce_60 = happySpecReduce_1 27 happyReduction_60
+happyReduction_60 _
+	 =  HappyAbsSyn27
+		 (Minus
+	)
+
+happyReduce_61 = happySpecReduce_1 27 happyReduction_61
+happyReduction_61 _
+	 =  HappyAbsSyn27
+		 (Plus
+	)
+
+happyReduce_62 = happySpecReduce_1 27 happyReduction_62
+happyReduction_62 _
+	 =  HappyAbsSyn27
+		 (Not
+	)
+
+happyReduce_63 = happySpecReduce_1 28 happyReduction_63
+happyReduction_63 (HappyAbsSyn15  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Var happy_var_1
+	)
+happyReduction_63 _  = notHappyAtAll 
+
+happyReduce_64 = happySpecReduce_1 28 happyReduction_64
+happyReduction_64 (HappyAbsSyn29  happy_var_1)
+	 =  HappyAbsSyn19
+		 (Lit happy_var_1
+	)
+happyReduction_64 _  = notHappyAtAll 
+
+happyReduce_65 = happySpecReduce_1 29 happyReduction_65
+happyReduction_65 (HappyTerminal (T_literal happy_var_1))
+	 =  HappyAbsSyn29
+		 (happy_var_1
+	)
+happyReduction_65 _  = notHappyAtAll 
+
+happyReduce_66 = happySpecReduce_1 30 happyReduction_66
+happyReduction_66 (HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn19
+		 (happy_var_1
+	)
+happyReduction_66 _  = notHappyAtAll 
+
+happyReduce_67 = happySpecReduce_2 31 happyReduction_67
+happyReduction_67 (HappyAbsSyn32  happy_var_2)
+	_
+	 =  HappyAbsSyn6
+		 (let (spec, decls) = happy_var_2 in Typedef spec [] decls
+	)
+happyReduction_67 _ _  = notHappyAtAll 
+
+happyReduce_68 = happySpecReduce_1 31 happyReduction_68
+happyReduction_68 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn6
+		 (TypeDecl happy_var_1
+	)
+happyReduction_68 _  = notHappyAtAll 
+
+happyReduce_69 = happySpecReduce_1 31 happyReduction_69
+happyReduction_69 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn6
+		 (TypeDecl happy_var_1
+	)
+happyReduction_69 _  = notHappyAtAll 
+
+happyReduce_70 = happySpecReduce_1 31 happyReduction_70
+happyReduction_70 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn6
+		 (TypeDecl happy_var_1
+	)
+happyReduction_70 _  = notHappyAtAll 
+
+happyReduce_71 = happySpecReduce_2 32 happyReduction_71
+happyReduction_71 (HappyAbsSyn38  happy_var_2)
+	(HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn32
+		 ((happy_var_1,happy_var_2)
+	)
+happyReduction_71 _ _  = notHappyAtAll 
+
+happyReduce_72 = happySpecReduce_1 33 happyReduction_72
+happyReduction_72 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_72 _  = notHappyAtAll 
+
+happyReduce_73 = happySpecReduce_1 33 happyReduction_73
+happyReduction_73 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_73 _  = notHappyAtAll 
+
+happyReduce_74 = happySpecReduce_1 34 happyReduction_74
+happyReduction_74 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_74 _  = notHappyAtAll 
+
+happyReduce_75 = happySpecReduce_1 34 happyReduction_75
+happyReduction_75 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_75 _  = notHappyAtAll 
+
+happyReduce_76 = happySpecReduce_1 34 happyReduction_76
+happyReduction_76 (HappyAbsSyn15  happy_var_1)
+	 =  HappyAbsSyn18
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_76 _  = notHappyAtAll 
+
+happyReduce_77 = happySpecReduce_1 35 happyReduction_77
+happyReduction_77 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_77 _  = notHappyAtAll 
+
+happyReduce_78 = happySpecReduce_1 35 happyReduction_78
+happyReduction_78 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_78 _  = notHappyAtAll 
+
+happyReduce_79 = happySpecReduce_1 35 happyReduction_79
+happyReduction_79 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_79 _  = notHappyAtAll 
+
+happyReduce_80 = happySpecReduce_1 35 happyReduction_80
+happyReduction_80 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_80 _  = notHappyAtAll 
+
+happyReduce_81 = happySpecReduce_1 35 happyReduction_81
+happyReduction_81 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_81 _  = notHappyAtAll 
+
+happyReduce_82 = happySpecReduce_1 35 happyReduction_82
+happyReduction_82 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_82 _  = notHappyAtAll 
+
+happyReduce_83 = happySpecReduce_1 35 happyReduction_83
+happyReduction_83 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_83 _  = notHappyAtAll 
+
+happyReduce_84 = happySpecReduce_1 35 happyReduction_84
+happyReduction_84 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_84 _  = notHappyAtAll 
+
+happyReduce_85 = happySpecReduce_1 36 happyReduction_85
+happyReduction_85 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_85 _  = notHappyAtAll 
+
+happyReduce_86 = happySpecReduce_1 36 happyReduction_86
+happyReduction_86 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_86 _  = notHappyAtAll 
+
+happyReduce_87 = happySpecReduce_1 36 happyReduction_87
+happyReduction_87 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_87 _  = notHappyAtAll 
+
+happyReduce_88 = happySpecReduce_1 36 happyReduction_88
+happyReduction_88 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_88 _  = notHappyAtAll 
+
+happyReduce_89 = happySpecReduce_1 37 happyReduction_89
+happyReduction_89 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_89 _  = notHappyAtAll 
+
+happyReduce_90 = happySpecReduce_1 37 happyReduction_90
+happyReduction_90 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_90 _  = notHappyAtAll 
+
+happyReduce_91 = happySpecReduce_1 37 happyReduction_91
+happyReduction_91 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_91 _  = notHappyAtAll 
+
+happyReduce_92 = happySpecReduce_1 38 happyReduction_92
+happyReduction_92 (HappyAbsSyn39  happy_var_1)
+	 =  HappyAbsSyn38
+		 ([happy_var_1]
+	)
+happyReduction_92 _  = notHappyAtAll 
+
+happyReduce_93 = happySpecReduce_3 38 happyReduction_93
+happyReduction_93 (HappyAbsSyn39  happy_var_3)
+	_
+	(HappyAbsSyn38  happy_var_1)
+	 =  HappyAbsSyn38
+		 (happy_var_3 : happy_var_1
+	)
+happyReduction_93 _ _ _  = notHappyAtAll 
+
+happyReduce_94 = happySpecReduce_1 39 happyReduction_94
+happyReduction_94 (HappyAbsSyn39  happy_var_1)
+	 =  HappyAbsSyn39
+		 (happy_var_1
+	)
+happyReduction_94 _  = notHappyAtAll 
+
+happyReduce_95 = happySpecReduce_1 40 happyReduction_95
+happyReduction_95 (HappyAbsSyn39  happy_var_1)
+	 =  HappyAbsSyn39
+		 (happy_var_1
+	)
+happyReduction_95 _  = notHappyAtAll 
+
+happyReduce_96 = happySpecReduce_2 40 happyReduction_96
+happyReduction_96 (HappyAbsSyn65  happy_var_2)
+	(HappyAbsSyn39  happy_var_1)
+	 =  HappyAbsSyn39
+		 (ArrayId happy_var_1 happy_var_2
+	)
+happyReduction_96 _ _  = notHappyAtAll 
+
+happyReduce_97 = happySpecReduce_1 41 happyReduction_97
+happyReduction_97 (HappyTerminal (T_float happy_var_1))
+	 =  HappyAbsSyn18
+		 (TyFloat happy_var_1
+	)
+happyReduction_97 _  = notHappyAtAll 
+
+happyReduce_98 = happySpecReduce_1 42 happyReduction_98
+happyReduction_98 (HappyTerminal (T_int happy_var_1))
+	 =  HappyAbsSyn18
+		 (TyInteger happy_var_1
+	)
+happyReduction_98 _  = notHappyAtAll 
+
+happyReduce_99 = happySpecReduce_2 42 happyReduction_99
+happyReduction_99 (HappyTerminal (T_int happy_var_2))
+	_
+	 =  HappyAbsSyn18
+		 (TyApply (TySigned True)  (TyInteger happy_var_2)
+	)
+happyReduction_99 _ _  = notHappyAtAll 
+
+happyReduce_100 = happySpecReduce_2 42 happyReduction_100
+happyReduction_100 (HappyTerminal (T_int happy_var_2))
+	_
+	 =  HappyAbsSyn18
+		 (TyApply (TySigned False) (TyInteger happy_var_2)
+	)
+happyReduction_100 _ _  = notHappyAtAll 
+
+happyReduce_101 = happySpecReduce_1 43 happyReduction_101
+happyReduction_101 _
+	 =  HappyAbsSyn18
+		 (TyChar
+	)
+
+happyReduce_102 = happySpecReduce_1 44 happyReduction_102
+happyReduction_102 _
+	 =  HappyAbsSyn18
+		 (TyWChar
+	)
+
+happyReduce_103 = happySpecReduce_1 45 happyReduction_103
+happyReduction_103 _
+	 =  HappyAbsSyn18
+		 (TyBool
+	)
+
+happyReduce_104 = happySpecReduce_1 46 happyReduction_104
+happyReduction_104 _
+	 =  HappyAbsSyn18
+		 (TyOctet
+	)
+
+happyReduce_105 = happySpecReduce_1 47 happyReduction_105
+happyReduction_105 _
+	 =  HappyAbsSyn18
+		 (TyAny
+	)
+
+happyReduce_106 = happySpecReduce_1 48 happyReduction_106
+happyReduction_106 _
+	 =  HappyAbsSyn18
+		 (TyObject
+	)
+
+happyReduce_107 = happyReduce 5 49 happyReduction_107
+happyReduction_107 (_ `HappyStk`
+	(HappyAbsSyn50  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn39  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (TyStruct (Just happy_var_2) happy_var_4 Nothing
+	) `HappyStk` happyRest
+
+happyReduce_108 = happySpecReduce_1 50 happyReduction_108
+happyReduction_108 (HappyAbsSyn51  happy_var_1)
+	 =  HappyAbsSyn50
+		 ([happy_var_1]
+	)
+happyReduction_108 _  = notHappyAtAll 
+
+happyReduce_109 = happySpecReduce_2 50 happyReduction_109
+happyReduction_109 (HappyAbsSyn51  happy_var_2)
+	(HappyAbsSyn50  happy_var_1)
+	 =  HappyAbsSyn50
+		 (happy_var_2:happy_var_1
+	)
+happyReduction_109 _ _  = notHappyAtAll 
+
+happyReduce_110 = happySpecReduce_3 51 happyReduction_110
+happyReduction_110 _
+	(HappyAbsSyn38  happy_var_2)
+	(HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn51
+		 ((happy_var_1,[],happy_var_2)
+	)
+happyReduction_110 _ _ _  = notHappyAtAll 
+
+happyReduce_111 = happyReduce 9 52 happyReduction_111
+happyReduction_111 (_ `HappyStk`
+	(HappyAbsSyn54  happy_var_8) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_5) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn39  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (TyUnion (Just happy_var_2) happy_var_5 (Id "tagged_union") Nothing (reverse happy_var_8)
+	) `HappyStk` happyRest
+
+happyReduce_112 = happySpecReduce_1 53 happyReduction_112
+happyReduction_112 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_112 _  = notHappyAtAll 
+
+happyReduce_113 = happySpecReduce_1 53 happyReduction_113
+happyReduction_113 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_113 _  = notHappyAtAll 
+
+happyReduce_114 = happySpecReduce_1 53 happyReduction_114
+happyReduction_114 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_114 _  = notHappyAtAll 
+
+happyReduce_115 = happySpecReduce_1 53 happyReduction_115
+happyReduction_115 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_115 _  = notHappyAtAll 
+
+happyReduce_116 = happySpecReduce_1 53 happyReduction_116
+happyReduction_116 (HappyAbsSyn15  happy_var_1)
+	 =  HappyAbsSyn18
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_116 _  = notHappyAtAll 
+
+happyReduce_117 = happySpecReduce_1 54 happyReduction_117
+happyReduction_117 (HappyAbsSyn55  happy_var_1)
+	 =  HappyAbsSyn54
+		 ([happy_var_1]
+	)
+happyReduction_117 _  = notHappyAtAll 
+
+happyReduce_118 = happySpecReduce_2 54 happyReduction_118
+happyReduction_118 (HappyAbsSyn55  happy_var_2)
+	(HappyAbsSyn54  happy_var_1)
+	 =  HappyAbsSyn54
+		 (happy_var_2:happy_var_1
+	)
+happyReduction_118 _ _  = notHappyAtAll 
+
+happyReduce_119 = happySpecReduce_3 55 happyReduction_119
+happyReduction_119 _
+	(HappyAbsSyn58  happy_var_2)
+	(HappyAbsSyn56  happy_var_1)
+	 =  HappyAbsSyn55
+		 (Switch happy_var_1 (Just happy_var_2)
+	)
+happyReduction_119 _ _ _  = notHappyAtAll 
+
+happyReduce_120 = happySpecReduce_1 56 happyReduction_120
+happyReduction_120 (HappyAbsSyn57  happy_var_1)
+	 =  HappyAbsSyn56
+		 ([happy_var_1]
+	)
+happyReduction_120 _  = notHappyAtAll 
+
+happyReduce_121 = happySpecReduce_2 56 happyReduction_121
+happyReduction_121 (HappyAbsSyn57  happy_var_2)
+	(HappyAbsSyn56  happy_var_1)
+	 =  HappyAbsSyn56
+		 (happy_var_2:happy_var_1
+	)
+happyReduction_121 _ _  = notHappyAtAll 
+
+happyReduce_122 = happySpecReduce_3 57 happyReduction_122
+happyReduction_122 _
+	(HappyAbsSyn19  happy_var_2)
+	_
+	 =  HappyAbsSyn57
+		 (Case [happy_var_2]
+	)
+happyReduction_122 _ _ _  = notHappyAtAll 
+
+happyReduce_123 = happySpecReduce_2 57 happyReduction_123
+happyReduction_123 _
+	_
+	 =  HappyAbsSyn57
+		 (Default
+	)
+
+happyReduce_124 = happySpecReduce_2 58 happyReduction_124
+happyReduction_124 (HappyAbsSyn39  happy_var_2)
+	(HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn58
+		 ((Param happy_var_2 happy_var_1 [])
+	)
+happyReduction_124 _ _  = notHappyAtAll 
+
+happyReduce_125 = happyReduce 5 59 happyReduction_125
+happyReduction_125 (_ `HappyStk`
+	(HappyAbsSyn60  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn39  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (TyEnum (Just happy_var_2) (reverse happy_var_4)
+	) `HappyStk` happyRest
+
+happyReduce_126 = happySpecReduce_1 60 happyReduction_126
+happyReduction_126 (HappyAbsSyn39  happy_var_1)
+	 =  HappyAbsSyn60
+		 ([(happy_var_1,[],Nothing)]
+	)
+happyReduction_126 _  = notHappyAtAll 
+
+happyReduce_127 = happySpecReduce_3 60 happyReduction_127
+happyReduction_127 (HappyAbsSyn39  happy_var_3)
+	_
+	(HappyAbsSyn60  happy_var_1)
+	 =  HappyAbsSyn60
+		 (((happy_var_3,[],Nothing):happy_var_1)
+	)
+happyReduction_127 _ _ _  = notHappyAtAll 
+
+happyReduce_128 = happyReduce 6 61 happyReduction_128
+happyReduction_128 (_ `HappyStk`
+	(HappyAbsSyn19  happy_var_5) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (TySequence happy_var_3 (Just happy_var_5)
+	) `HappyStk` happyRest
+
+happyReduce_129 = happyReduce 4 61 happyReduction_129
+happyReduction_129 (_ `HappyStk`
+	(HappyAbsSyn18  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (TySequence happy_var_3 Nothing
+	) `HappyStk` happyRest
+
+happyReduce_130 = happyReduce 4 62 happyReduction_130
+happyReduction_130 (_ `HappyStk`
+	(HappyAbsSyn19  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (TyString (Just happy_var_3)
+	) `HappyStk` happyRest
+
+happyReduce_131 = happySpecReduce_1 62 happyReduction_131
+happyReduction_131 _
+	 =  HappyAbsSyn18
+		 (TyString Nothing
+	)
+
+happyReduce_132 = happyReduce 4 63 happyReduction_132
+happyReduction_132 (_ `HappyStk`
+	(HappyAbsSyn19  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (TyWString (Just happy_var_3)
+	) `HappyStk` happyRest
+
+happyReduce_133 = happySpecReduce_1 63 happyReduction_133
+happyReduction_133 _
+	 =  HappyAbsSyn18
+		 (TyWString Nothing
+	)
+
+happyReduce_134 = happySpecReduce_2 64 happyReduction_134
+happyReduction_134 (HappyAbsSyn65  happy_var_2)
+	(HappyAbsSyn39  happy_var_1)
+	 =  HappyAbsSyn64
+		 ((happy_var_1, reverse happy_var_2)
+	)
+happyReduction_134 _ _  = notHappyAtAll 
+
+happyReduce_135 = happySpecReduce_1 65 happyReduction_135
+happyReduction_135 (HappyAbsSyn19  happy_var_1)
+	 =  HappyAbsSyn65
+		 ([happy_var_1]
+	)
+happyReduction_135 _  = notHappyAtAll 
+
+happyReduce_136 = happySpecReduce_2 65 happyReduction_136
+happyReduction_136 (HappyAbsSyn19  happy_var_2)
+	(HappyAbsSyn65  happy_var_1)
+	 =  HappyAbsSyn65
+		 (happy_var_2:happy_var_1
+	)
+happyReduction_136 _ _  = notHappyAtAll 
+
+happyReduce_137 = happySpecReduce_3 66 happyReduction_137
+happyReduction_137 _
+	(HappyAbsSyn19  happy_var_2)
+	_
+	 =  HappyAbsSyn19
+		 (happy_var_2
+	)
+happyReduction_137 _ _ _  = notHappyAtAll 
+
+happyReduce_138 = happyReduce 4 67 happyReduction_138
+happyReduction_138 ((HappyAbsSyn38  happy_var_4) `HappyStk`
+	(HappyAbsSyn18  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn68  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn6
+		 (Attribute (reverse happy_var_4) happy_var_1 happy_var_3
+	) `HappyStk` happyRest
+
+happyReduce_139 = happySpecReduce_1 68 happyReduction_139
+happyReduction_139 _
+	 =  HappyAbsSyn68
+		 (True
+	)
+
+happyReduce_140 = happySpecReduce_0 68 happyReduction_140
+happyReduction_140  =  HappyAbsSyn68
+		 (False
+	)
+
+happyReduce_141 = happySpecReduce_1 69 happyReduction_141
+happyReduction_141 (HappyAbsSyn39  happy_var_1)
+	 =  HappyAbsSyn38
+		 ([happy_var_1]
+	)
+happyReduction_141 _  = notHappyAtAll 
+
+happyReduce_142 = happySpecReduce_3 69 happyReduction_142
+happyReduction_142 (HappyAbsSyn39  happy_var_3)
+	_
+	(HappyAbsSyn38  happy_var_1)
+	 =  HappyAbsSyn38
+		 (happy_var_3:happy_var_1
+	)
+happyReduction_142 _ _ _  = notHappyAtAll 
+
+happyReduce_143 = happyReduce 5 70 happyReduction_143
+happyReduction_143 (_ `HappyStk`
+	(HappyAbsSyn50  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn39  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn6
+		 (Exception happy_var_2 happy_var_4
+	) `HappyStk` happyRest
+
+happyReduce_144 = happySpecReduce_0 71 happyReduction_144
+happyReduction_144  =  HappyAbsSyn50
+		 ([]
+	)
+
+happyReduce_145 = happySpecReduce_1 71 happyReduction_145
+happyReduction_145 (HappyAbsSyn50  happy_var_1)
+	 =  HappyAbsSyn50
+		 (happy_var_1
+	)
+happyReduction_145 _  = notHappyAtAll 
+
+happyReduce_146 = happySpecReduce_1 72 happyReduction_146
+happyReduction_146 (HappyAbsSyn51  happy_var_1)
+	 =  HappyAbsSyn50
+		 ([happy_var_1]
+	)
+happyReduction_146 _  = notHappyAtAll 
+
+happyReduce_147 = happySpecReduce_2 72 happyReduction_147
+happyReduction_147 (HappyAbsSyn51  happy_var_2)
+	(HappyAbsSyn50  happy_var_1)
+	 =  HappyAbsSyn50
+		 (happy_var_2:happy_var_1
+	)
+happyReduction_147 _ _  = notHappyAtAll 
+
+happyReduce_148 = happyReduce 6 73 happyReduction_148
+happyReduction_148 ((HappyAbsSyn81  happy_var_6) `HappyStk`
+	(HappyAbsSyn80  happy_var_5) `HappyStk`
+	(HappyAbsSyn76  happy_var_4) `HappyStk`
+	(HappyAbsSyn39  happy_var_3) `HappyStk`
+	(HappyAbsSyn18  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn6
+		 (Operation (FunId happy_var_3 Nothing happy_var_4) happy_var_2 happy_var_5 happy_var_6
+	) `HappyStk` happyRest
+
+happyReduce_149 = happySpecReduce_0 74 happyReduction_149
+happyReduction_149  =  HappyAbsSyn68
+		 (False
+	)
+
+happyReduce_150 = happySpecReduce_1 74 happyReduction_150
+happyReduction_150 _
+	 =  HappyAbsSyn68
+		 (True
+	)
+
+happyReduce_151 = happySpecReduce_1 75 happyReduction_151
+happyReduction_151 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_151 _  = notHappyAtAll 
+
+happyReduce_152 = happySpecReduce_1 75 happyReduction_152
+happyReduction_152 _
+	 =  HappyAbsSyn18
+		 (TyVoid
+	)
+
+happyReduce_153 = happySpecReduce_3 76 happyReduction_153
+happyReduction_153 _
+	(HappyAbsSyn76  happy_var_2)
+	_
+	 =  HappyAbsSyn76
+		 ((reverse happy_var_2)
+	)
+happyReduction_153 _ _ _  = notHappyAtAll 
+
+happyReduce_154 = happySpecReduce_2 76 happyReduction_154
+happyReduction_154 _
+	_
+	 =  HappyAbsSyn76
+		 ([]
+	)
+
+happyReduce_155 = happySpecReduce_1 77 happyReduction_155
+happyReduction_155 (HappyAbsSyn78  happy_var_1)
+	 =  HappyAbsSyn76
+		 ([happy_var_1]
+	)
+happyReduction_155 _  = notHappyAtAll 
+
+happyReduce_156 = happySpecReduce_3 77 happyReduction_156
+happyReduction_156 (HappyAbsSyn78  happy_var_3)
+	_
+	(HappyAbsSyn76  happy_var_1)
+	 =  HappyAbsSyn76
+		 (happy_var_3:happy_var_1
+	)
+happyReduction_156 _ _ _  = notHappyAtAll 
+
+happyReduce_157 = happySpecReduce_3 78 happyReduction_157
+happyReduction_157 (HappyAbsSyn39  happy_var_3)
+	(HappyAbsSyn18  happy_var_2)
+	(HappyAbsSyn79  happy_var_1)
+	 =  HappyAbsSyn78
+		 (Param happy_var_3 happy_var_2 [happy_var_1]
+	)
+happyReduction_157 _ _ _  = notHappyAtAll 
+
+happyReduce_158 = happySpecReduce_1 79 happyReduction_158
+happyReduction_158 (HappyTerminal (T_mode happy_var_1))
+	 =  HappyAbsSyn79
+		 (Mode happy_var_1
+	)
+happyReduction_158 _  = notHappyAtAll 
+
+happyReduce_159 = happySpecReduce_0 80 happyReduction_159
+happyReduction_159  =  HappyAbsSyn80
+		 (Nothing
+	)
+
+happyReduce_160 = happyReduce 4 80 happyReduction_160
+happyReduction_160 (_ `HappyStk`
+	(HappyAbsSyn82  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn80
+		 (Just (reverse happy_var_3)
+	) `HappyStk` happyRest
+
+happyReduce_161 = happySpecReduce_0 81 happyReduction_161
+happyReduction_161  =  HappyAbsSyn81
+		 (Nothing
+	)
+
+happyReduce_162 = happyReduce 4 81 happyReduction_162
+happyReduction_162 (_ `HappyStk`
+	(HappyAbsSyn82  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn81
+		 (Just (reverse happy_var_3)
+	) `HappyStk` happyRest
+
+happyReduce_163 = happySpecReduce_1 82 happyReduction_163
+happyReduction_163 (HappyAbsSyn15  happy_var_1)
+	 =  HappyAbsSyn82
+		 ([happy_var_1]
+	)
+happyReduction_163 _  = notHappyAtAll 
+
+happyReduce_164 = happySpecReduce_3 82 happyReduction_164
+happyReduction_164 (HappyAbsSyn15  happy_var_3)
+	_
+	(HappyAbsSyn82  happy_var_1)
+	 =  HappyAbsSyn82
+		 (happy_var_3:happy_var_1
+	)
+happyReduction_164 _ _ _  = notHappyAtAll 
+
+happyReduce_165 = happySpecReduce_1 83 happyReduction_165
+happyReduction_165 (HappyTerminal (T_string_lit happy_var_1))
+	 =  HappyAbsSyn82
+		 ([happy_var_1]
+	)
+happyReduction_165 _  = notHappyAtAll 
+
+happyReduce_166 = happySpecReduce_3 83 happyReduction_166
+happyReduction_166 (HappyTerminal (T_string_lit happy_var_3))
+	_
+	(HappyAbsSyn82  happy_var_1)
+	 =  HappyAbsSyn82
+		 (happy_var_3:happy_var_1
+	)
+happyReduction_166 _ _ _  = notHappyAtAll 
+
+happyReduce_167 = happySpecReduce_1 84 happyReduction_167
+happyReduction_167 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_167 _  = notHappyAtAll 
+
+happyReduce_168 = happySpecReduce_1 84 happyReduction_168
+happyReduction_168 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_168 _  = notHappyAtAll 
+
+happyReduce_169 = happySpecReduce_1 84 happyReduction_169
+happyReduction_169 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_169 _  = notHappyAtAll 
+
+happyReduce_170 = happySpecReduce_1 84 happyReduction_170
+happyReduction_170 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_170 _  = notHappyAtAll 
+
+happyReduce_171 = happySpecReduce_1 84 happyReduction_171
+happyReduction_171 (HappyAbsSyn15  happy_var_1)
+	 =  HappyAbsSyn18
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_171 _  = notHappyAtAll 
+
+happyReduce_172 = happyReduce 6 85 happyReduction_172
+happyReduction_172 (_ `HappyStk`
+	(HappyAbsSyn87  happy_var_5) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn19  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (TyFixed (Just (happy_var_3,happy_var_5))
+	) `HappyStk` happyRest
+
+happyReduce_173 = happySpecReduce_1 86 happyReduction_173
+happyReduction_173 _
+	 =  HappyAbsSyn18
+		 (TyFixed Nothing
+	)
+
+happyReduce_174 = happySpecReduce_1 87 happyReduction_174
+happyReduction_174 (HappyTerminal (T_literal happy_var_1))
+	 =  HappyAbsSyn87
+		 (let (IntegerLit il) = happy_var_1 in il
+	)
+happyReduction_174 _  = notHappyAtAll 
+
+happyReduce_175 = happySpecReduce_1 88 happyReduction_175
+happyReduction_175 (HappyTerminal (T_string_lit happy_var_1))
+	 =  HappyAbsSyn15
+		 (happy_var_1
+	)
+happyReduction_175 _  = notHappyAtAll 
+
+happyReduce_176 = happySpecReduce_1 89 happyReduction_176
+happyReduction_176 (HappyTerminal (T_id happy_var_1))
+	 =  HappyAbsSyn39
+		 ((Id happy_var_1)
+	)
+happyReduction_176 _  = notHappyAtAll 
+
+happyNewToken action sts stk
+	= lexIDL(\tk -> 
+	let cont i = action i i tk (HappyState action) sts stk in
+	case tk of {
+	T_eof -> action 162 162 (error "reading EOF!") (HappyState action) sts stk;
+	T_semi -> cont 90;
+	T_module -> cont 91;
+	T_interface -> cont 92;
+	T_oparen -> cont 93;
+	T_cparen -> cont 94;
+	T_ocurly -> cont 95;
+	T_ccurly -> cont 96;
+	T_colon -> cont 97;
+	T_dcolon -> cont 98;
+	T_comma -> cont 99;
+	T_dot -> cont 100;
+	T_const -> cont 101;
+	T_equal -> cont 102;
+	T_eqeq -> cont 103;
+	T_neq -> cont 104;
+	T_or -> cont 105;
+	T_rel_or -> cont 106;
+	T_xor -> cont 107;
+	T_and -> cont 108;
+	T_rel_and -> cont 109;
+	T_shift happy_dollar_dollar -> cont 110;
+	T_div -> cont 111;
+	T_mod -> cont 112;
+	T_not -> cont 113;
+	T_negate -> cont 114;
+	T_question -> cont 115;
+	T_typedef -> cont 116;
+	T_type happy_dollar_dollar -> cont 117;
+	T_float happy_dollar_dollar -> cont 118;
+	T_int happy_dollar_dollar -> cont 119;
+	T_unsigned -> cont 120;
+	T_signed -> cont 121;
+	T_char -> cont 122;
+	T_wchar -> cont 123;
+	T_boolean -> cont 124;
+	T_struct -> cont 125;
+	T_union -> cont 126;
+	T_switch -> cont 127;
+	T_case -> cont 128;
+	T_default -> cont 129;
+	T_enum -> cont 130;
+	T_lt -> cont 131;
+	T_le -> cont 132;
+	T_gt -> cont 133;
+	T_ge -> cont 134;
+	T_osquare -> cont 135;
+	T_csquare -> cont 136;
+	T_void -> cont 137;
+	T_mode happy_dollar_dollar -> cont 138;
+	T_literal happy_dollar_dollar -> cont 139;
+	T_string_lit happy_dollar_dollar -> cont 140;
+	T_id happy_dollar_dollar -> cont 141;
+	T_attribute -> cont 142;
+	T_plus -> cont 143;
+	T_times -> cont 144;
+	T_minus -> cont 145;
+	T_string -> cont 146;
+	T_wstring -> cont 147;
+	T_sequence -> cont 148;
+	T_object -> cont 149;
+	T_any -> cont 150;
+	T_octet -> cont 151;
+	T_oneway -> cont 152;
+	T_fixed -> cont 153;
+	T_exception -> cont 154;
+	T_raises -> cont 155;
+	T_context -> cont 156;
+	T_readonly -> cont 157;
+	T_include_start happy_dollar_dollar -> cont 158;
+	T_include_end -> cont 159;
+	T_pragma happy_dollar_dollar -> cont 160;
+	T_unknown happy_dollar_dollar -> cont 161;
+	_ -> happyError
+	})
+
+happyThen :: LexM a -> (a -> LexM b) -> LexM b
+happyThen = (thenLexM)
+happyReturn :: a -> LexM a
+happyReturn = (returnLexM)
+happyThen1 = happyThen
+happyReturn1 = happyReturn
+
+parseIDL = happyThen (happyParse action_0) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll })
+
+happySeq = happyDontSeq
+
+happyError :: LexM a
+happyError = do
+ l   <- getSrcLoc
+ str <- getStream
+ ioToLexM (ioError (userError (show l ++ ": Parse error: " ++ takeWhile (/='\n') str)))
+{-# LINE 1 "GenericTemplate.hs" #-}
+-- $Id: GenericTemplate.hs,v 1.23 2002/05/23 09:24:27 simonmar Exp $
+
+{-# LINE 15 "GenericTemplate.hs" #-}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+infixr 9 `HappyStk`
+data HappyStk a = HappyStk a (HappyStk a)
+
+-----------------------------------------------------------------------------
+-- starting the parse
+
+happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
+
+-----------------------------------------------------------------------------
+-- Accepting the parse
+
+happyAccept j tk st sts (HappyStk ans _) = 
+
+					   (happyReturn1 ans)
+
+-----------------------------------------------------------------------------
+-- Arrays only: do the next action
+
+{-# LINE 150 "GenericTemplate.hs" #-}
+
+
+-----------------------------------------------------------------------------
+-- HappyState data type (not arrays)
+
+
+
+newtype HappyState b c = HappyState
+        (Int ->                    -- token number
+         Int ->                    -- token number (yes, again)
+         b ->                           -- token semantic value
+         HappyState b c ->              -- current state
+         [HappyState b c] ->            -- state stack
+         c)
+
+
+
+-----------------------------------------------------------------------------
+-- Shifting a token
+
+happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =
+     let i = (case x of { HappyErrorToken (i) -> i }) in
+--     trace "shifting the error token" $
+     new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)
+
+happyShift new_state i tk st sts stk =
+     happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)
+
+-- happyReduce is specialised for the common cases.
+
+happySpecReduce_0 i fn (1) tk st sts stk
+     = happyFail (1) tk st sts stk
+happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk
+     = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)
+
+happySpecReduce_1 i fn (1) tk st sts stk
+     = happyFail (1) tk st sts stk
+happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')
+     = let r = fn v1 in
+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))
+
+happySpecReduce_2 i fn (1) tk st sts stk
+     = happyFail (1) tk st sts stk
+happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')
+     = let r = fn v1 v2 in
+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))
+
+happySpecReduce_3 i fn (1) tk st sts stk
+     = happyFail (1) tk st sts stk
+happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
+     = let r = fn v1 v2 v3 in
+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))
+
+happyReduce k i fn (1) tk st sts stk
+     = happyFail (1) tk st sts stk
+happyReduce k nt fn j tk st sts stk
+     = case happyDrop (k - ((1) :: Int)) sts of
+	 sts1@(((st1@(HappyState (action))):(_))) ->
+        	let r = fn stk in  -- it doesn't hurt to always seq here...
+       		happyDoSeq r (action nt j tk st1 sts1 r)
+
+happyMonadReduce k nt fn (1) tk st sts stk
+     = happyFail (1) tk st sts stk
+happyMonadReduce k nt fn j tk st sts stk =
+        happyThen1 (fn stk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))
+       where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))
+             drop_stk = happyDropStk k stk
+
+happyDrop (0) l = l
+happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t
+
+happyDropStk (0) l = l
+happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs
+
+-----------------------------------------------------------------------------
+-- Moving to a new state after a reduction
+
+
+
+
+
+
+
+
+
+happyGoto action j tk st = action j j tk (HappyState action)
+
+
+-----------------------------------------------------------------------------
+-- Error recovery ((1) is the error token)
+
+-- parse error if we are in recovery and we fail again
+happyFail  (1) tk old_st _ stk =
+--	trace "failing" $ 
+    	happyError
+
+
+{-  We don't need state discarding for our restricted implementation of
+    "error".  In fact, it can cause some bogus parses, so I've disabled it
+    for now --SDM
+
+-- discard a state
+happyFail  (1) tk old_st (((HappyState (action))):(sts)) 
+						(saved_tok `HappyStk` _ `HappyStk` stk) =
+--	trace ("discarding state, depth " ++ show (length stk))  $
+	action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))
+-}
+
+-- Enter error recovery: generate an error token,
+--                       save the old token and carry on.
+happyFail  i tk (HappyState (action)) sts stk =
+--      trace "entering error recovery" $
+	action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)
+
+-- Internal happy errors:
+
+notHappyAtAll = error "Internal Happy error\n"
+
+-----------------------------------------------------------------------------
+-- Hack to get the typechecker to accept our action functions
+
+
+
+
+
+
+
+-----------------------------------------------------------------------------
+-- Seq-ing.  If the --strict flag is given, then Happy emits 
+--	happySeq = happyDoSeq
+-- otherwise it emits
+-- 	happySeq = happyDontSeq
+
+happyDoSeq, happyDontSeq :: a -> b -> b
+happyDoSeq   a b = a `seq` b
+happyDontSeq a b = b
+
+-----------------------------------------------------------------------------
+-- Don't inline any functions from the template.  GHC has a nasty habit
+-- of deciding to inline happyGoto everywhere, which increases the size of
+-- the generated parser quite a bit.
+
+
+
+
+
+
+
+
+
+{-# NOINLINE happyShift #-}
+{-# NOINLINE happySpecReduce_0 #-}
+{-# NOINLINE happySpecReduce_1 #-}
+{-# NOINLINE happySpecReduce_2 #-}
+{-# NOINLINE happySpecReduce_3 #-}
+{-# NOINLINE happyReduce #-}
+{-# NOINLINE happyMonadReduce #-}
+{-# NOINLINE happyGoto #-}
+{-# NOINLINE happyFail #-}
+
+-- end of Happy Template.
+ src/OmgParser.y view
@@ -0,0 +1,470 @@+{
+{-
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+% @(#) $Docid: Jul. 12th 2001  10:08  Sigbjorn Finne $
+% @(#) $Contactid: sof@galconn.com $
+%
+
+A grammar for OMG CORBA IDL
+
+-}
+module OmgParser ( parseIDL ) where
+
+import LexM
+import Lex
+import IDLToken
+import IDLSyn
+import BasicTypes
+import Literal
+{-
+BEGIN_GHC_ONLY
+import GlaExts
+END_GHC_ONLY
+-}
+}
+
+%name parseIDL
+%tokentype { IDLToken }
+%monad { LexM } {thenLexM } { returnLexM }
+%lexer { lexIDL } { T_eof }
+%token
+	';'	      { T_semi }
+        MODULE	      { T_module }
+        INTERFACE     { T_interface }
+        '('           { T_oparen }
+        ')'           { T_cparen }
+        '{'           { T_ocurly }
+        '}'           { T_ccurly }
+        ':'           { T_colon  }
+        '::'          { T_dcolon  }
+        ','           { T_comma }
+        '.'           { T_dot }
+        CONST         { T_const }
+        '='           { T_equal }
+        '=='          { T_eqeq }
+        '!='          { T_neq }
+        '|'           { T_or }
+        '||'          { T_rel_or }
+        '^'           { T_xor }
+        '&'           { T_and }
+        '&&'          { T_rel_and }
+        SHIFT         { T_shift $$ }
+        '/'           { T_div }
+        '%'           { T_mod }
+        '~'           { T_not }
+        '!'           { T_negate }
+        '?'           { T_question }
+        TYPEDEF       { T_typedef }
+        TYPE          { T_type $$ }
+        FLOAT         { T_float $$ }
+        INTEGER       { T_int $$ }
+        UNSIGNED      { T_unsigned }
+        SIGNED        { T_signed }
+        CHAR          { T_char }
+        WCHAR         { T_wchar }
+        BOOLEAN       { T_boolean }
+        STRUCT        { T_struct }
+        UNION         { T_union }
+        SWITCH        { T_switch }
+        CASE          { T_case }
+        DEFAULT       { T_default }
+        ENUM          { T_enum }
+        '<'           { T_lt }
+        '<='          { T_le }
+        '>'           { T_gt }
+        '>='          { T_ge }
+        '['           { T_osquare }
+        ']'           { T_csquare }
+        VOID          { T_void }
+        MODE          { T_mode $$ }
+        LITERAL       { T_literal $$ }
+        STRING_LIT    { T_string_lit $$ }
+	ID	      { T_id $$ }
+	ATTRIBUTE     { T_attribute }
+	'+'	      { T_plus }
+	'*'	      { T_times }
+	'-'	      { T_minus }
+	STRING        { T_string }
+	WSTRING       { T_wstring }
+	SEQUENCE      { T_sequence  }
+	OBJECT        { T_object }
+	ANY           { T_any }
+        OCTET         { T_octet }
+	ONEWAY	      { T_oneway }
+	FIXED	      { T_fixed }
+	EXCEPTION     { T_exception }
+	RAISES        { T_raises }
+	CONTEXT       { T_context }
+	READONLY      { T_readonly }
+        INCLUDE_START { T_include_start $$ }
+	INCLUDE_END   { T_include_end }
+	PRAGMA        { T_pragma $$ }
+        UNKNOWN       { T_unknown $$ }
+%%
+
+specification :: { [Defn] }
+   : definitions	     { (reverse $1) }
+
+definitions  :: { [Defn] }
+   :                         {    []   }
+   | definitions definition  { $2 : $1 }
+
+definition   :: { Defn }
+   : type_decl   ';'	    { $1 }
+   | const_decl  ';'        { $1 }
+   | except_decl ';'        { $1 }
+   | interface   ';'        { $1 }
+   | module      ';'        { $1 }
+   | PRAGMA                 { Pragma $1 }
+   | INCLUDE_START          { IncludeStart $1 }
+   | INCLUDE_END            { IncludeEnd }
+
+module :: { Defn }
+   : MODULE identifier '{' definitions '}'  { Module $2 (reverse $4) }
+
+interface :: { Defn }
+   : interface_decl	    { $1 }
+   | INTERFACE identifier   { Forward $2 }
+
+interface_decl :: { Defn }
+   : interface_header '{' exports '}'  { let (ids,inherit) = $1 in Interface ids inherit (reverse $3) }
+
+interface_header :: { (Id, Inherit) }
+   : INTERFACE identifier opt_inheritance_spec { ($2,$3) }
+
+exports :: { [Defn] }
+   : {-empty-}			{    []   }
+   | exports export		{ $2 : $1 }
+
+export  :: { Defn }
+   : type_decl ';'	      { $1 }
+   | const_decl ';'	      { $1 }
+   | except_decl ';'          { $1 }
+   | attr_decl ';'	      { $1 }
+   | op_decl ';'	      { $1 }
+
+opt_inheritance_spec :: { Inherit }
+   : {-empty-}	              { [] }
+   | inheritance_spec	      { $1 }
+
+inheritance_spec :: { Inherit }
+   : ':' scoped_name more_scoped_names  { $2:(reverse $3) }
+
+scoped_name :: { String }
+   : ID					{ $1  }
+   | '::' ID				{ ("::"++ $2)  }
+   | scoped_name '::' ID		{ $1 ++ ':':':':$3 }
+
+more_scoped_names :: { Inherit }
+   : {-empty-}			       { [] }
+   | ',' scoped_name more_scoped_names { $2 : $3 }
+
+{- constant declarations -}
+
+const_decl :: { Defn }
+   : CONST const_type identifier '=' const_expr  { Constant $3 [] $2 $5 }
+
+const_type :: { Type }
+   : integer_type		{ $1 }
+   | char_type			{ $1 }
+   | wide_char_type		{ $1 }
+   | boolean_type		{ $1 }
+   | floating_pt_type		{ $1 }
+   | string_type		{ $1 }
+   | wide_string_type		{ $1 }
+   | fixed_pt_const_type	{ $1 }
+   | scoped_name		{ TyName $1 Nothing }
+
+const_expr :: { Expr }
+   : or_expr			{ $1 }
+
+or_expr :: { Expr }
+   : xor_expr			{ $1 }
+   | or_expr '|' xor_expr	{ Binary Or $1 $3 }
+
+xor_expr :: { Expr }
+   : and_expr			{ $1 }
+   | xor_expr '^' and_expr	{ Binary Xor $1 $3 }
+
+and_expr :: { Expr }
+   : shift_expr			{ $1 }
+   | and_expr '&' shift_expr    { Binary And $1 $3 }
+   
+shift_expr :: { Expr }
+   : add_expr			{ $1 }
+   | shift_expr SHIFT add_expr  { Binary (Shift $2) $1 $3 }
+
+add_expr :: { Expr }
+   : mult_expr			{ $1 }
+   | add_expr '+' mult_expr     { Binary Add $1 $3 }
+   | add_expr '-' mult_expr     { Binary Sub $1 $3 }
+
+mult_expr :: { Expr }
+   : unary_expr			{ $1 }
+   | mult_expr '*' unary_expr   { Binary Mul $1 $3 }
+   | mult_expr '/' unary_expr   { Binary Div $1 $3 }
+   | mult_expr '%' unary_expr   { Binary Mod $1 $3 }
+
+unary_expr :: { Expr }
+   : unary_operator primary_expr { Unary $1 $2 }
+   | primary_expr		 { $1 }
+
+unary_operator :: { UnaryOp }
+   : '-'	{ Minus }
+   | '+'	{ Plus  }
+   | '~'	{ Not   }
+
+primary_expr :: { Expr }
+   : scoped_name		{ Var $1 }
+   | literal			{ Lit $1 }
+
+literal :: { Literal }
+   : LITERAL			{ $1 }
+
+positive_int_const :: { Expr }
+   : const_expr				{ $1 }
+
+{---- type declarations ------}
+
+type_decl   :: { Defn }
+   : TYPEDEF type_declarator		{ let (spec, decls) = $2 in Typedef spec [] decls }
+   | struct_type			{ TypeDecl $1 }
+   | union_type 			{ TypeDecl $1 }
+   | enum_type  			{ TypeDecl $1 }
+
+type_declarator :: { (Type, [Id]) }
+   : type_spec declarators		{ ($1,$2) }
+
+type_spec :: { Type }
+   : simple_type_spec			{ $1 }
+   | constr_type_spec			{ $1 }
+   
+
+simple_type_spec :: { Type }
+   : base_type_spec			{ $1 }
+   | template_type_spec			{ $1 }
+   | scoped_name			{ TyName $1 Nothing }
+
+base_type_spec :: { Type }
+   : floating_pt_type			{ $1 }
+   | integer_type			{ $1 }
+   | char_type				{ $1 }
+   | wide_char_type			{ $1 }
+   | boolean_type			{ $1 }
+   | octet_type				{ $1 }
+   | any_type				{ $1 }
+   | object_type			{ $1 }
+
+template_type_spec :: { Type }
+   : sequence_type			{ $1 }
+   | string_type			{ $1 }
+   | wide_string_type			{ $1 }
+   | fixed_pt_type			{ $1 }
+
+constr_type_spec :: { Type }
+   : struct_type			{ $1 }
+   | union_type				{ $1 }
+   | enum_type				{ $1 }
+
+declarators :: { [Id] }
+   : declarator				{ [$1] }
+   | declarators ',' declarator		{ $3 : $1 }
+
+simple_declarator ::  { Id }
+   : identifier				{ $1 }
+
+declarator :: { Id }
+   : identifier				{ $1 }
+   | identifier fixed_array_sizes	{ ArrayId $1 $2 }
+
+floating_pt_type :: { Type }
+   : FLOAT			{ TyFloat $1 }
+
+integer_type :: { Type }
+   : INTEGER			{ TyInteger $1 }
+   | SIGNED INTEGER		{ TyApply (TySigned True)  (TyInteger $2) }
+   | UNSIGNED INTEGER		{ TyApply (TySigned False) (TyInteger $2) }
+
+char_type :: { Type }
+   : CHAR	{ TyChar }
+
+wide_char_type :: { Type }
+   : WCHAR	{ TyWChar }
+
+
+boolean_type :: { Type }
+   : BOOLEAN	{ TyBool }
+
+octet_type   :: { Type }
+   : OCTET      { TyOctet }
+
+any_type     :: { Type }
+   : ANY	{ TyAny }
+
+object_type  :: { Type }
+   : OBJECT     { TyObject }
+
+struct_type :: { Type }
+   : STRUCT identifier '{' member_list '}' { TyStruct (Just $2) $4 Nothing }
+
+member_list :: { [Member] }
+   : member		{ [$1] }
+   | member_list member { $2:$1 }
+   
+member ::      { Member }
+   : type_spec declarators ';'	{ ($1,[],$2) }
+
+union_type  ::	{ Type }
+   : UNION identifier SWITCH '(' switch_type_spec ')' '{' switch_body '}' 
+ 			{ TyUnion (Just $2) $5 (Id "tagged_union") Nothing (reverse $8) }
+
+switch_type_spec :: { Type }
+   : integer_type	{ $1 }
+   | char_type		{ $1 }
+   | boolean_type	{ $1 }
+   | enum_type		{ $1 }
+   | scoped_name	{ TyName $1 Nothing }
+
+switch_body :: { [Switch] }
+   : case		{ [$1]  }
+   | switch_body case   { $2:$1 }
+
+case :: { Switch }
+   : case_labels element_spec ';' { Switch $1 (Just $2) }
+
+case_labels :: { [CaseLabel] }
+   : case_label			{ [$1]  }
+   | case_labels case_label     { $2:$1 }
+
+case_label :: { CaseLabel }
+   : CASE const_expr ':'	{ Case [$2] }
+   | DEFAULT ':'		{ Default }
+
+element_spec :: { SwitchArm }
+   : type_spec declarator	{ (Param $2 $1 []) }
+
+enum_type :: { Type }
+   : ENUM identifier '{' enumerators '}' { TyEnum (Just $2) (reverse $4) }
+
+enumerators :: { [(Id,[Attribute],Maybe Expr)] }
+   : identifier				{ [($1,[],Nothing)] }
+   | enumerators ',' identifier		{ (($3,[],Nothing):$1) }
+
+sequence_type :: { Type }
+   : SEQUENCE '<' simple_type_spec ',' positive_int_const '>' { TySequence $3 (Just $5) }
+   | SEQUENCE '<' simple_type_spec '>' { TySequence $3 Nothing }
+
+string_type   :: { Type }
+   : STRING '<' positive_int_const '>'	{ TyString (Just $3) }
+   | STRING				{ TyString Nothing   }
+
+wide_string_type   :: { Type }
+   : WSTRING '<' positive_int_const '>'	{ TyWString (Just $3) }
+   | WSTRING				{ TyWString Nothing   }
+
+array_declarator :: { (Id, [Expr]) }
+   : identifier fixed_array_sizes		{ ($1, reverse $2) }
+
+fixed_array_sizes :: { [Expr] }
+   : fixed_array_size			{  [$1] }
+   | fixed_array_sizes fixed_array_size { $2:$1 }
+
+fixed_array_size  :: { Expr }
+   : '[' positive_int_const ']'		{ $2 }
+
+attr_decl   :: { Defn }
+   : opt_readonly ATTRIBUTE param_type_spec simple_declarators { Attribute (reverse $4) $1 $3 }
+
+opt_readonly :: { Bool }
+   : READONLY   { True } | {-empty-} { False }
+
+simple_declarators :: { [Id] }
+   : simple_declarator		{ [$1] }
+   | simple_declarators ',' simple_declarator { $3:$1 }
+
+except_decl :: { Defn }
+   : EXCEPTION identifier '{' mb_members '}' { Exception $2 $4 }
+
+mb_members :: { [Member] }
+   : {-empty-}			{ [] }
+   | members			{ $1 }
+
+members :: { [Member] }
+   : member			{ [$1] }
+   | members member		{ $2:$1 }
+
+op_decl :: { Defn }
+   : opt_op_attribute op_type_spec identifier parameter_decls mb_raises_expr mb_context_expr
+		{ Operation (FunId $3 Nothing $4) $2 $5 $6 }
+
+opt_op_attribute :: { Bool }
+   : {-nothing-}			{ False }
+   | ONEWAY				{ True  }
+
+op_type_spec :: { Type }
+   : param_type_spec			{ $1 }
+   | VOID				{ TyVoid }
+
+parameter_decls :: { [Param] }
+   : '(' param_decls ')'		{ (reverse $2) }
+   | '(' ')'				{ [] }
+
+param_decls :: { [Param] }
+   : param_decl				{ [$1] }
+   | param_decls ',' param_decl		{ $3:$1 }
+
+param_decl :: { Param }
+   : param_attribute param_type_spec simple_declarator { Param $3 $2 [$1] }
+
+param_attribute :: { Attribute }
+   : MODE	{ Mode $1 }
+
+mb_raises_expr :: { Maybe Raises }
+   : {-nothing-}		{ Nothing }
+   | RAISES '(' scoped_name_list ')' { Just (reverse $3) }
+
+mb_context_expr :: { Maybe Context }
+   : {-nothing-}		     { Nothing }
+   | CONTEXT '(' string_lit_list ')' { Just (reverse $3) }
+
+scoped_name_list :: { [String] }
+   : scoped_name			{ [$1] }
+   | scoped_name_list ',' scoped_name	{ $3:$1 }
+
+string_lit_list  :: { [String] }
+   : STRING_LIT				{ [$1] }
+   | string_lit_list ',' STRING_LIT     { $3:$1 }
+
+param_type_spec :: { Type }
+   : base_type_spec		{ $1 }
+   | string_type		{ $1 }
+   | wide_string_type		{ $1 }
+   | fixed_pt_type		{ $1 }
+   | scoped_name		{ TyName $1 Nothing }
+
+fixed_pt_type	:: { Type }
+   : FIXED '<' positive_int_const ',' integer_literal '>' { TyFixed (Just ($3,$5)) }
+
+fixed_pt_const_type :: { Type }
+   : FIXED	{ TyFixed Nothing }
+
+integer_literal :: { IntegerLit }
+   : LITERAL	{ let (IntegerLit il) = $1 in il }
+
+string_literal  :: { String }
+   : STRING_LIT { $1 }
+
+identifier :: { Id }
+    : ID   { (Id $1) }
+    
+{------------------ END OF GRAMMAR --------------}
+
+{
+happyError :: LexM a
+happyError = do
+ l   <- getSrcLoc
+ str <- getStream
+ ioToLexM (ioError (userError (show l ++ ": Parse error: " ++ takeWhile (/='\n') str)))
+}
+ src/Opts.lhs view
@@ -0,0 +1,730 @@+% 
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Dec. 9th 2003  08:37  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+\begin{code}
+module Opts where
+
+import Data.IORef
+import GetOpt
+import System
+import System.IO.Unsafe ( unsafePerformIO)
+import IO     ( hPutStrLn, stderr )
+import Monad  ( when )
+import Utils  ( split, trace, notNull )
+import Version
+{- BEGIN_USE_REGISTRY
+import Utils ( bailIf, hdirect_root )
+import 
+       Win32Registry  ( hKEY_LOCAL_MACHINE, regQueryValue, regOpenKeyEx, kEY_READ, regEnumKeyVals )
+import 
+       StdDIS	      ( MbString )
+   END_USE_REGISTRY -}
+
+\end{code}
+
+Grimy stuff - to make it sort of possible to use the compiler
+from within Hugs. 
+
+\begin{code}
+ihc_opts :: [Option]
+ihc_opts = unsafePerformIO $ do
+  args <- readIORef the_ihc_opts
+  return (snd (getOpts options [] args))
+
+the_ihc_opts :: IORef [String]
+the_ihc_opts = unsafePerformIO $ do
+    args <- getArgs
+    let args' = expandDerivedArgs args ++ defaultArgs
+    when ("-v" `elem` args') (hPutStrLn stderr ("Effective command line: " ++ unwords args'))
+    newIORef args'
+
+theOpts :: [String]
+theOpts = unsafePerformIO (readIORef the_ihc_opts)
+
+expandDerivedArgs :: [String] -> [String]
+expandDerivedArgs ls =
+  case ls of
+    []     -> []
+    (x:xs) ->
+      case (lookup x derivedArgs) of
+	Nothing -> x : expandDerivedArgs xs
+	Just ys -> let xs' = expandDerivedArgs xs in ys ++ xs'
+
+defaultArgs :: [String]
+defaultArgs =
+  case filter ((== "default").fst) registryOptions of
+    ((_,o):_) -> o
+    _         -> []
+
+derivedArgs :: [(String, [String])]
+derivedArgs = 
+  ("-fautomation", autoOptions):
+  filter ((/= "default").fst) registryOptions
+
+autoOptions :: [String]
+autoOptions = words $
+{- BEGIN_USE_REGISTRY
+  unsafePerformIO $
+  catch 
+    (do
+      hk <- regOpenKeyEx hKEY_LOCAL_MACHINE hdirect_root kEY_READ
+      v <- regQueryValue hk (Just "CurrentVersion") 
+      bailIf (null v) (return default_opts) $ do
+       -- figure out where the latest dist resides.
+      hk <- regOpenKeyEx hKEY_LOCAL_MACHINE (hdirect_root ++ "options\\" ++ v) kEY_READ
+       -- lookup the import dir for the latest version
+      v <- regQueryValue hk (Just "-fautomation")
+      bailIf (null v) (return default_opts) (return v))
+    (\ _ -> return default_opts)
+ END_USE_REGISTRY -}
+{- BEGIN_NOT_USE_REGISTRY -}
+ default_opts
+{- END_NOT_USE_REGISTRY -}
+  where
+   default_opts = "-fno-export-list -fcom -fcoalesce-methods -fno-gen-binary-interface"
+
+registryOptions :: [(String,[String])]
+{- BEGIN_NOT_USE_REGISTRY -}
+registryOptions = []
+{- END_NOT_USE_REGISTRY   -}
+{- BEGIN_USE_REGISTRY
+registryOptions = unsafePerformIO $
+  catch 
+    (do
+      hk <- regOpenKeyEx hKEY_LOCAL_MACHINE hdirect_root kEY_READ
+      v <- regQueryValue hk (Just "CurrentVersion") 
+      hk <- regOpenKeyEx hKEY_LOCAL_MACHINE (hdirect_root ++ '\\':v ++ "\\options") kEY_READ
+      vs <- regEnumKeyVals hk
+      let
+        readOne (s,v,_) = do
+	 return (s,words v)
+      ls <- mapM readOne vs
+      return ls)
+    (\ _ -> return [])
+   END_USE_REGISTRY -}
+
+set_ihc_opts :: [String] -> IO ()
+set_ihc_opts args = writeIORef the_ihc_opts args
+\end{code}
+
+\begin{code}
+dumpIDL, dumpDesugar, dumpRenamer, dumpAbstractH :: Bool
+dumpIDL        = any (DumpIDL==)     ihc_opts
+dumpDesugar    = any (DumpDesugar==) ihc_opts
+dumpRenamer    = any (DumpRenamer==) ihc_opts
+dumpAbstractH  = any (DumpAbsH==)    ihc_opts
+
+optGreenCard, optTargetGhc, optCpp, optNoOutput :: Bool
+optGreenCard   = any (OptGreenCard==) ihc_opts
+optTargetGhc   = any (OptTargetGhc==) ihc_opts
+optCpp         = any (OptCpp==)      ihc_opts
+optNoOutput    = any (OptNoOutput==) ihc_opts
+
+optVersion, optHelp, optDebug, optVerbose, optGenHeader :: Bool
+optVersion     = any (DumpVersion==) ihc_opts
+optHelp	       = any (DumpHelp==)    ihc_opts
+optDebug       = any (DumpDebug==)   ihc_opts
+optVerbose     = any (DumpVerbose==) ihc_opts
+optGenHeader   = any (OptGenHeader==) ihc_opts
+
+optExportListWithTySig, optNoExportList, optNoModuleHeader :: Bool
+optExportListWithTySig = any (OptExportTySig==) ihc_opts
+optNoExportList   = any (OptNoExportList==)   ihc_opts
+optNoModuleHeader = any (OptNoModuleHeader==) ihc_opts
+
+optExpandInheritedInterface, optCoalesceIsomorphicMethods :: Bool
+optExpandInheritedInterface = not (any (OptNoExpandInherit==) ihc_opts)
+optCoalesceIsomorphicMethods = any (OptCoalesceIsomorphicMethods==) ihc_opts
+
+optNoDllName :: Bool
+optNoDllName = any (OptNoDllName==) ihc_opts
+
+optKeepHRESULT, optUseDispIDs, optIntsEverywhere, optIntAsWord :: Bool
+optKeepHRESULT    = any (OptKeepHResult==) ihc_opts
+optUseDispIDs     = any (OptUseDispIDs==)  ihc_opts
+optIntsEverywhere = any (OptUseInts==)     ihc_opts
+optIntAsWord      = any (OptIntAsWord==)   ihc_opts
+
+optShowPasses, optConvertImportLibs, optSortDefns, optWinnowDefns :: Bool
+optShowPasses     = any (OptShowPasses==)  ihc_opts
+optConvertImportLibs = any (OptConvertImportLibs==) ihc_opts
+optSortDefns       = any (OptSortDefns==) ihc_opts
+optWinnowDefns     = any (OptWinnowDefns==) ihc_opts
+
+optOnlyRemoveDefns, optDon'tGenBinaryComInterfaces :: Bool
+optOnlyRemoveDefns = any (OptOnlyRemoveDefns==) ihc_opts
+optDon'tGenBinaryComInterfaces = any (OptDon'tGenBinaryComInterfaces==) ihc_opts
+
+optOutPointersAreRefs, optQualInstanceMethods :: Bool
+optOutPointersAreRefs    = not $ any (OptOutPointersAreNotRefs==) ihc_opts
+optQualInstanceMethods   = any (OptQualInstanceMethods==) ihc_opts
+
+optNoDerefRefs :: Bool
+optNoDerefRefs = any (OptNoDerefRefs==) ihc_opts
+
+optIntIsInt, optIgnoreSourceIfaces, optNoEnumMagic, optEnumsAsFlags :: Bool
+optIntIsInt                = any (OptIntIsInt==) ihc_opts
+optIgnoreSourceIfaces      = any (OptIgnoreSourceIfaces==) ihc_opts || optHugs
+optNoEnumMagic             = any (OptNoEnumMagic==) ihc_opts
+optEnumsAsFlags            = any (OptEnumsAsFlags==) ihc_opts
+
+optGenBitsInstance, optGenNumInstance :: Bool
+optGenBitsInstance        = any (OptGenBitsInstance==) ihc_opts
+optGenNumInstance         = any (OptGenNumInstance==) ihc_opts
+
+optLongLongIsInteger, optNukeEmptyStructs, optShortHeader, optIntCoercesInPrelude :: Bool
+optLongLongIsInteger	   = any (OptLongLongIsInteger==) ihc_opts
+optNukeEmptyStructs	   = any (OptNukeEmptyStructs==) ihc_opts
+optShortHeader		   = any (OptShortHeader==) ihc_opts
+optIntCoercesInPrelude     = any (OptIntCoercesInPrelude==) ihc_opts
+
+optServer, optOneModulePerInterface, optShowIDLInComments :: Bool
+optServer       = any (OptServer==) ihc_opts
+optOneModulePerInterface = any (OptOneModulePerInterface==) ihc_opts
+optShowIDLInComments = any (OptShowIDLInComments==) ihc_opts
+
+optUnparamedInterfacePointers :: Bool
+optUnparamedInterfacePointers = any (OptUnParam'dIPointers==) ihc_opts
+
+-- Subtyped interface pointers are the default, only way turn this off
+-- is via the use of -funparamed-interface-pointers. (or -fhs-to-c.)
+optSubtypedInterfacePointers :: Bool
+optSubtypedInterfacePointers = 
+    any (OptSubTypedInterfacePointers==) ihc_opts ||
+    (not optUnparamedInterfacePointers && not optHaskellToC)
+
+optNoImportLists, optNoImports, optNoQualNames :: Bool
+optNoImportLists   = any (OptNoImportLists==) ihc_opts
+optNoImports       = any (OptNoImports==) ihc_opts
+optNoQualNames     = any (OptNoQualNames==) ihc_opts
+
+optNoDependentArgs, optNoLibIds :: Bool
+optNoDependentArgs = any (OptNoDependentArgs==) ihc_opts
+optNoLibIds	   = any (OptNoLibraryIds==)    ihc_opts
+
+optPrefixIfaceName, optAppendIfaceName, optDeepMarshall :: Bool
+optPrefixIfaceName = any (OptPrefixIfaceName==) ihc_opts
+optAppendIfaceName = any (OptAppendIfaceName==) ihc_opts
+optDeepMarshall    = not (any (OptShallowMarshall==) ihc_opts)
+
+optNoMangleIfaceNames, optExportAbstractly :: Bool
+optNoMangleIfaceNames = any (OptNoMangleIfaceNames==) ihc_opts
+optExportAbstractly   = any (OptExportAbstractly==) ihc_opts
+
+optIgnoreDispInterfaces, optDualVtbl, optCompilingDceIDL :: Bool
+optIgnoreDispInterfaces = any (OptIgnoreDispInterfaces==) ihc_opts
+optDualVtbl		= any (OptDualVtbl==) ihc_opts
+optCompilingDceIDL	= any (OptCompilingDceIDL==) ihc_opts
+-- MsIDL is currently the default.
+optCompilingMsIDL, optCompilingOmgIDL :: Bool
+optCompilingMsIDL	= any (OptCompilingMsIDL==) ihc_opts 
+			    || (not optCompilingDceIDL && not optCompilingOmgIDL)
+optCompilingOmgIDL	= any (OptCompilingOmgIDL==) ihc_opts
+
+optHaskellToC, optIgnoreHelpstring, optTlb :: Bool
+optHaskellToC		= any (OptHaskellToC==) ihc_opts
+optIgnoreHelpstring     = any (OptIgnoreHelpstring==) ihc_opts
+optTlb			= any (OptTLB==)  ihc_opts
+
+optIgnoreImpLibs, optHugs, optSkel, optUnsafeCalls :: Bool
+optIgnoreImpLibs	= any (OptIgnoreImpLibs==)  ihc_opts
+optHugs			= any (OptHugs==) ihc_opts
+optSkel                 = any (OptSkel==) ihc_opts
+optUnsafeCalls	        = any (OptUnsafeCalls==) ihc_opts
+
+optH1_4, optIgnoreHiddenMeths, optIgnoreRestrictedMeths :: Bool
+optH1_4			= any (OptH1_4==) ihc_opts
+optIgnoreHiddenMeths    = any (OptIgnoreHiddenMeths==) ihc_opts
+optIgnoreRestrictedMeths = any (OptIgnoreRestrictedMeths==) ihc_opts
+
+optOptionalAsMaybe, optNoVariantInstance, optVariantInstance :: Bool
+optOptionalAsMaybe       = any (OptOptionalAsMaybe==) ihc_opts
+optNoVariantInstance     = any (OptNoVariantInstance==) ihc_opts
+optVariantInstance       = any (OptVariantInstance==) ihc_opts
+
+optOutputTlb, optPatternAsLambda, optClassicNameMangling :: Bool
+optOutputTlb             = any (OptOutputTlb==) ihc_opts
+optPatternAsLambda       = any (OptPatternAsLambda==) ihc_opts
+optClassicNameMangling   = any (OptClassicNameMangling==) ihc_opts
+
+optGenDefs, optOverloadVariant, optNoOverloadVariant :: Bool
+optGenDefs               = any (OptGenDefs==) ihc_opts
+optOverloadVariant       = any (OptOverloadVariant==) ihc_opts
+optNoOverloadVariant     = any (OptNoOverloadVariant==) ihc_opts
+
+optGenCStubs, optExplicitIPointer, optAnonTLB :: Bool
+optGenCStubs		 = any (OptGenCStubs==) ihc_opts
+optExplicitIPointer      = any (OptExpIPointer==) ihc_opts
+optAnonTLB               = any (OptAnonTLB==) ihc_opts
+
+optUnwrapSingletonStructs, optJNI, optCorba :: Bool
+optUnwrapSingletonStructs = any (OptUnwrapSingletonStructs==) ihc_opts
+optJNI			 = any (OptJNI==) ihc_opts
+optCorba		 = any (OptCorba==) ihc_opts
+
+optCharPtrIsString, optInlineTypes :: Bool
+optCharPtrIsString       = any (OptCharPtrIsString==) ihc_opts
+optInlineTypes           = any (OptInlineTypes==) ihc_opts
+
+optIncludeAsImport, optExcludeSysIncludes :: Bool
+optIncludeAsImport       = any (OptIncludeAsImport==) ihc_opts
+optExcludeSysIncludes    = any (OptExcludeSysIncludes==) ihc_opts
+
+optVoidTydefIsAbstract, optNoWarnMissingMode :: Bool
+optVoidTydefIsAbstract   = any (OptVoidTydefIsAbstract==) ihc_opts
+optNoWarnMissingMode     = any (OptNoWarnMissingMode==) ihc_opts
+
+optDon'tTidyDefns, optSmartEnums, optNoShareFIDs, optUseStdDispatch, optUseIIDIs :: Bool
+optDon'tTidyDefns        = any (OptDon'tTidyDefns==) ihc_opts
+optSmartEnums            = any (OptSmartEnums==) ihc_opts
+optNoShareFIDs           = any (OptNoShareFIDs==) ihc_opts
+optUseStdDispatch        = any (OptUseStdDispatch==) ihc_opts
+optUseIIDIs              = any (OptUseIIDIs==) ihc_opts
+
+optNoWideStrings :: Bool
+optNoWideStrings         = any (OptNoWideStrings==) ihc_opts
+
+optCom :: Bool
+optCom = not optJNI && not optCorba && not optHaskellToC && not optCompilingOmgIDL
+
+optIgnoreMethsUpto :: Maybe String
+optIgnoreMethsUpto       = 
+   case [ p | OptIgnoreMethsUpto p <- ihc_opts ] of
+     [] -> Nothing
+     ls -> Just (last ls)  -- last entry on the command line wins.
+
+optPointerDefault :: Maybe String
+optPointerDefault        = 
+   case [ p | OptPointerDefault p <- ihc_opts ] of
+     [] -> Nothing
+     ls -> Just (last ls)  -- last entry on the command line wins.
+
+optOutputDumpTo :: Maybe String
+optOutputDumpTo          = 
+   case [ p | OptOutputDump p <- ihc_opts ] of
+     [] -> Nothing
+     ls -> Just (last ls)  -- last entry on the command line wins.
+
+optOutputModules :: [String]
+optOutputModules = [ f | OptOutputModule f <- ihc_opts ]
+
+optOutputHTo :: [String]
+optOutputHTo   = [ f | OptOutputHTo f <- ihc_opts ]
+optOutputTlbTo :: [String]
+optOutputTlbTo = [ f | OptOutputTlbTo f <- ihc_opts ]
+
+optFiles :: [String]
+optFiles       = [ f | OptFile f <- ihc_opts]
+optAsfs  :: [String]
+optAsfs        = [ f | OptAsf f  <- ihc_opts]
+optUseAsfs :: Bool
+optUseAsfs     = notNull optAsfs
+optOFiles :: [String]
+optOFiles      = [ o | OptOutputFile o <- ihc_opts] 
+optODirs  :: [String]
+optODirs       = [ o | OptOutputDir o <- ihc_opts ] -- a smelly one (sorry, couldn't resist :)
+
+optincludedirs :: [String]
+optincludedirs = 
+{- BEGIN_SUPPORT_TYPELIBS 
+  concat [split ';' d | OptIncludeDirs d <- reverse ihc_opts]
+   END_SUPPORT_TYPELIBS -}
+{- BEGIN_NOT_SUPPORT_TYPELIBS -}
+  concat [split ':' d | OptIncludeDirs d <- reverse ihc_opts]
+{- END_NOT_SUPPORT_TYPELIBS -}
+
+optinclude_cppdirs :: [String]
+optinclude_cppdirs = 
+  concat [split ':' d | OptIncludeCppDirs d <- reverse ihc_opts]
+
+optcpp_defines :: [String]
+optcpp_defines = [ d | OptCppDefine d <- reverse ihc_opts]
+
+optIncludeHeaders, optIncludeCHeaders :: [String]
+optIncludeHeaders = [ d | OptIncludeHeader d <- reverse ihc_opts]
+optIncludeCHeaders = [ d | OptIncludeCHeader d <- reverse ihc_opts]
+\end{code}
+
+Printing out some info about the package in question:
+
+\begin{code}
+name, version :: String
+name    = pkg_name
+version = pkg_version
+
+version_msg :: String
+version_msg = 
+ unlines
+ [ name ++ ", " ++ version
+ , ""
+ , "Report bugs to <sof@galconn.com>"
+ ]
+
+usage_msg :: String -> String
+usage_msg pgm = 
+ unlines
+ [ "Usage: " ++ pgm ++ " [OPTION]... SOURCE"
+ , ""
+ , "Run H/Direct, an IDL compiler for Haskell, over SOURCE"
+ , ""
+ , " -h, --help      print out this help message and exit"
+ , " -v, --version   output version information and exit"
+ , " -o <file>       write H/Direct output to <file>"
+ , " -noC            don't generate any output files."
+ , " -i<dirs>, --include-dir <dirs>"
+ , "                 Add <dirs> to the include search path"
+ , "                 (<dirs> is colon separated.)"
+ , ""
+ , " -cpp            run the C pre-processor over input prior to"
+ , "                 before processing input"
+ , " -I<dirs>        Add <dirs> to C pre-processor's search path"
+ , "                 (<dirs> is colon separated.)"
+ , " --gc            output GreenCard stubs"
+ , " --hugs          output Hugs compatible stubs"
+ , " -g              generate GHC specific FFI code (i.e., _casm_ and _ccall_) "
+ , " --h1.4          generate Haskell 1.4 code (plus whateve FFI extension you're using)"
+ , " --gen-headers   output C header file corresponding to IDL spec."
+ , " --gen-tlb       generate type library/ies."
+ , ""
+ , " -fone-mod-per-iface  split output up into one Haskell module per (disp)interface"
+ , " -fuse-dispids        for Automation interfaces, generate stubs that use DISPIDs "
+ , "                      instead of method names"
+ , " -fkeep-hresult         don't squirrel away HRESULTs, but return them (COM specific.)"
+ , " -fno-export-list       generated Haskell module(s) should export everything"
+ , " -fno-expand-inherited  don't include methods of inherited interface"
+ , " -fno-module-header     don't emit module header"
+ , " -fcoalesce-methods     coalesce isomorphic methods."
+ , " -fexport-with-tysig    emit verbose export list containing function type signatures"
+ , " -fexport-transparent   export defined data types non-abstractly"
+ , " -fshow-idl-in-comments display original IDL in comments next to Haskell generated source"
+ , ""
+ , " -fmaybe-optional-params represent optional parameters via Maybe types (Automation specific)."
+ , " -fpattern-as-lambda     in the generated Haskell source, lambda bind parameters to toplevel"
+ , "                         parameters instead of using patterns (Meijer-style)."
+ , ""
+ , " -ftyped-interface-pointers    strongly type COM interface pointers"
+ , " -funtyped-interface-pointers  treat Automation interface pointers as"
+ , "                               generic IDispatch pointers"
+ , " -fsubtyped-interface-pointers encode interface inheritance in type of"
+ , "                               interface pointer (allows an interface that"
+ , "                               inherit to reuse methods of super interface.)"
+ , ""
+ , " -fignore-helpstrings          don't include helpstrings as comments in generated"
+ , "                               source."
+ , " -fignore-dispinterfaces       don't generate stub code for any dispinterface"
+ , "                               declarations encountered."
+ , " -fno-library-ids              don't bother generating libid declarations for library"
+ , "                               uuids."
+ , " -fignore-hidden-methods       don't generate stubs for [hidden] methods"
+ , " -fignore-restricted-methods   don't generate stubs for [restricted] methods"
+ , " -ftreat-importlibs-as-imports try to convert importlib() statements into imports."
+ , ""
+ , " -fsort-defns                  re-order the input to make definition occur be any use."
+ , ""
+ , " -fdual-vtbl                   for dual interfaces, generate stubs that invoke"
+ , "                               methods via vtbl entries rather than via IDispatch" 
+ , ""
+ , " -fno-import-lists             don't generate detailed import lists"
+ , " -fno-imports                  leave out import section alltogether"
+ , " -fno-qualified-names          don't qualify import names"
+ , " -fqualified-instance-methods"
+ , "                               qualify method names in instance decls"
+ , ""
+ , "-fno-dependent-args            turn off clever-mode for dependent args/fields"
+ , "-fno-gen-binary-interface      don't bother generating stubs for binary Com interfaces"
+ , "                               (useful when you're just interested in Automation)"
+ , "-fno-gen-variant-instances     don't generate Variant instances for enums"
+ , "                               (only of interest with Automation)."
+ , "-fgen-variant-instances        generate Variant instances for enums"
+ , ""
+ , "-fprefix-interface-name        to avoid name clashes, prefix interface name to methods"
+ , "-fappend-interface-short-name  to avoid name clashes, append upper case letters of"
+ , "                               interface name to methods"
+ , "-fprefix-interface-name        to avoid name clashes, prefix interface name to methods"
+ , "-fdeep-marshall                (un)marshall as much as possible"
+ , "-fout-pointers-are-not-refs    don't enforce the rule that says that [out] params have"
+ , "                               to be references."
+ , ""
+ , "-fuse-ints-everywhere          gen. code that use Int instead of sized Int/Word types"
+ , "-fint-as-word                  combined with previous, map all unsigned ints to Int"
+ , ""
+ , "-fstring-as-widestring         map wide strings to Haskell Strings"
+ , " -s                    server mode, generate stubs for Haskell COM objects"
+ , "                       (untested & support not yet finished.)"
+ , " --skel                generate skeleton implementation of coclasses"
+ , ""
+ , " -d, --debug     output extra debug information to stderr"
+ , " -ddump-idl      dump abstract syntax tree to stderr"
+ , " -ddump-ds       dump desugared/core IDL to stderr"
+ , " -ddump-absH     dump abstract Haskell to stderr"
+ , ""
+ , "Home page: http://www.haskell.org/hdirect/"
+ ]
+\end{code}
+
+\begin{code}
+options :: Opt [Option] ()
+options = 
+  (prefixed "-" $ 
+   opts
+      [ prefixed "-" $
+         opts 
+           [ "version"	    -=     DumpVersion
+   	   , "gc"	    -=     OptGreenCard
+	   , "hugs"	    -=     OptHugs
+	   , "gen-headers"  -=     OptGenHeader
+	   , "gen-defs"     -=     OptGenDefs
+           , "help"	    -=     DumpHelp
+           , "verbose"	    -=     DumpVerbose
+           , "debug"	    -=     DumpDebug
+           , "include-dir"  -===   OptIncludeDirs
+           , "include-header=" -== OptIncludeHeader
+           , "include-c-header=" -== OptIncludeCHeader
+	   , "jni"	    -=	   OptJNI
+	   , "corba"	    -=	   OptCorba
+	   , "skeleton"     -=     OptSkel
+	   , "tlb"	    -=     OptTLB
+	   , "unsafe-calls" -=     OptUnsafeCalls
+	   , "h1.4"         -=     OptH1_4
+	   , "gen-tlb"      -=     OptOutputTlb
+	   , "gen-c-stubs"  -=     OptGenCStubs
+	   , "output-tlb="    -==  OptOutputTlbTo
+	   , "output-h="      -==  OptOutputHTo
+	   , "output-module=" -==  OptOutputModule
+	   , "output-dump="   -==  OptOutputDump
+	   , "asf="           -==  OptAsf
+           ]
+      , prefixed "f" $
+         opts 
+	   [ "anon-typelib"                -= OptAnonTLB
+	   , "com"			   -= OptCompilingMsIDL
+	   , "char-ptr-is-string"	   -= OptCharPtrIsString
+	   , "classic-name-mangling"       -= OptClassicNameMangling
+	   , "dual-vtbl"		   -= OptDualVtbl
+	   , "export-with-tysig"           -= OptExportTySig
+	   , "export-abstractly"           -= OptExportAbstractly
+	   , "enums-as-flags"              -= OptEnumsAsFlags
+	   , "gen-bits-instance"           -= OptGenBitsInstance
+	   , "gen-num-instance"            -= OptGenNumInstance
+           , "keep-hresult"                -= OptKeepHResult
+	   , "maybe-optional-params"       -= OptOptionalAsMaybe
+           , "no-export-list"              -= OptNoExportList
+	   , "no-module-header"            -= OptNoModuleHeader
+	   , "no-tidy-defns"               -= OptDon'tTidyDefns
+	   , "no-share-ffi-decls"          -= OptNoShareFIDs
+           , "no-expand-inherited"         -= OptNoExpandInherit
+	   , "no-foreign-dll-name"         -= OptNoDllName
+           , "use-dispids"                 -= OptUseDispIDs
+	   , "ignore-importlibs"           -= OptIgnoreImpLibs
+	   , "ignore-methods-upto="        -== OptIgnoreMethsUpto
+	   , "int-is-int"                  -= OptIntIsInt
+	   , "int-prelude-coercions"       -= OptIntCoercesInPrelude
+           , "one-mod-per-iface"	   -= OptOneModulePerInterface
+	   , "coalesce-methods"		   -= OptCoalesceIsomorphicMethods
+	   , "show-idl-in-comments"	   -= OptShowIDLInComments
+	   , "compress-enums"              -= OptSmartEnums
+	   , "unparamed-interface-pointers"  -= OptUnParam'dIPointers
+	   , "subtyped-interface-pointers"  -= OptSubTypedInterfacePointers
+	   , "no-import-lists"		   -= OptNoImportLists
+	   , "no-imports"		   -= OptNoImports
+	   , "no-qualified-names"	   -= OptNoQualNames
+	   , "qualified-instance-methods"  -= OptQualInstanceMethods
+	   , "no-dependent-args"	   -= OptNoDependentArgs
+	   , "no-overload-variant"	   -= OptNoOverloadVariant
+	   , "no-enum-magic"               -= OptNoEnumMagic
+	   , "pattern-as-lambda"           -= OptPatternAsLambda
+	   , "prefix-interface-name"       -= OptPrefixIfaceName
+	   , "append-interface-short-name" -= OptAppendIfaceName
+	   , "shallow-marshall"		   -= OptShallowMarshall
+	   , "no-mangle-interface-names"   -= OptNoMangleIfaceNames
+	   , "no-gen-variant-instances"    -= OptNoVariantInstance
+	   , "gen-variant-instances"       -= OptVariantInstance
+	   , "ignore-dispinterfaces"       -= OptIgnoreDispInterfaces
+	   , "ignore-helpstrings"	   -= OptIgnoreHelpstring
+	   , "ignore-hidden-methods"       -= OptIgnoreHiddenMeths
+	   , "ignore-restricted-methods"   -= OptIgnoreRestrictedMeths
+	   , "ignore-source-interfaces"    -= OptIgnoreSourceIfaces
+	   , "include-as-import"           -= OptIncludeAsImport
+	   , "exclude-system-includes"     -= OptExcludeSysIncludes
+	   , "inline-synonyms"             -= OptInlineTypes
+	   , "longlong-as-integer"	   -= OptLongLongIsInteger
+	   , "explicit-i-pointer"          -= OptExpIPointer
+	   , "no-library-ids"              -= OptNoLibraryIds
+	   , "no-warn-missing-mode"        -= OptNoWarnMissingMode
+	   , "omg"			   -= OptCompilingOmgIDL
+	   , "pointer-default="            -== OptPointerDefault
+	   , "dce"			   -= OptCompilingDceIDL
+	   , "hs-to-c"			   -= OptHaskellToC
+	   , "use-ints-everywhere"         -= OptUseInts
+	   , "int-as-word"                 -= OptIntAsWord
+	   , "treat-importlibs-as-imports" -= OptConvertImportLibs
+	   , "sort-defns"		   -= OptSortDefns
+	   , "string-as-widestring"        -= OptNoWideStrings
+	   , "overload-variant"		   -= OptOverloadVariant
+	   , "remove-empty-structs"        -= OptNukeEmptyStructs
+	   , "only-remove-defns"	   -= OptOnlyRemoveDefns
+	   , "short-header"		   -= OptShortHeader
+	   , "no-gen-binary-interface"     -= OptDon'tGenBinaryComInterfaces
+	   , "out-pointers-are-not-refs"   -= OptOutPointersAreNotRefs
+	   , "no-deref-refs"               -= OptNoDerefRefs
+	   , "unwrap-singleton-structs"    -= OptUnwrapSingletonStructs
+	   , "use-std-dispatch"            -= OptUseStdDispatch
+	   , "use-iid-is"                  -= OptUseIIDIs
+	   , "void-typedef-is-abstract"    -= OptVoidTydefIsAbstract
+	   , "winnow-defns"		   -= OptWinnowDefns
+	   ]
+	   
+      , prefixed "ddump-" $
+               opts [ "ds"    -= DumpDesugar
+	            , "idl"   -= DumpIDL
+		    , "abs"   -= DumpAbsH
+		    , "rn"    -= DumpRenamer
+                    ],
+      "dshow-passes"    -= OptShowPasses,
+      "cpp"		-= OptCpp,
+      "h"		-= DumpHelp,
+      "d"		-= DumpDebug,
+      "v"		-= DumpVerbose,
+      "c"		-= OptIgnore,   -- accept, but vacuous.
+      "g"		-= OptTargetGhc,
+      "noC"             -= OptNoOutput,
+      "odir"            -=== OptOutputDir,
+      "otlb"            -=== OptOutputTlbTo,
+      "oh"		-=== OptOutputHTo,
+      "odump"           -=== OptOutputDump,
+      "o"		-=== OptOutputFile,
+      "s"               -= OptServer,
+      "i"		-== OptIncludeDirs,
+      "I"	        -== OptIncludeCppDirs,
+      "D"	        -== (\ s -> OptCppDefine ('-':'D':s)),
+      "U"	        -== (\ s -> OptCppDefine ('-':'U':s))
+     ]) `orOpt`
+    (((\ opt -> head opt == '-' && notNull (tail opt)) -? 
+		(\ opt -> trace ("Unrecognised option: " ++ opt ++ ", ignoring.") OptIgnore))
+		  `orOpt`
+    ((const True)  -? OptFile))
+
+data Option
+ = DumpVersion
+ | DumpHelp
+ | DumpDebug
+ | DumpVerbose
+ | DumpDesugar
+ | DumpRenamer
+ | DumpIDL
+ | DumpAbsH
+ | OptNoOutput
+ | OptCpp
+ | OptGreenCard
+ | OptHugs
+ | OptH1_4
+ | OptTargetGhc
+ | OptGenHeader
+ | OptSkel
+ | OptExportTySig
+ | OptNoExportList
+ | OptEnumsAsFlags
+ | OptNoModuleHeader
+ | OptNoExpandInherit
+ | OptNoDllName
+ | OptCoalesceIsomorphicMethods
+ | OptShowIDLInComments
+ | OptKeepHResult
+ | OptUseDispIDs
+ | OptServer
+ | OptOneModulePerInterface
+ | OptUnParam'dIPointers
+ | OptSubTypedInterfacePointers
+ | OptNoImportLists
+ | OptNoImports
+ | OptNoQualNames
+ | OptNoDependentArgs
+ | OptNoLibraryIds
+ | OptPrefixIfaceName
+ | OptAppendIfaceName
+ | OptShallowMarshall
+ | OptNoMangleIfaceNames
+ | OptExportAbstractly
+ | OptIgnoreDispInterfaces
+ | OptDualVtbl
+ | OptCompilingDceIDL
+ | OptCompilingMsIDL
+ | OptCompilingOmgIDL
+ | OptHaskellToC
+ | OptUseInts
+ | OptIgnore
+ | OptIntAsWord
+ | OptShowPasses
+ | OptConvertImportLibs
+ | OptIgnoreHelpstring
+ | OptSortDefns
+ | OptWinnowDefns
+ | OptOnlyRemoveDefns
+ | OptDon'tGenBinaryComInterfaces
+ | OptOutPointersAreNotRefs
+ | OptNoDerefRefs
+ | OptQualInstanceMethods
+ | OptTLB
+ | OptUnsafeCalls
+ | OptOutputTlb
+ | OptIgnoreHiddenMeths
+ | OptIgnoreRestrictedMeths
+ | OptIgnoreImpLibs
+ | OptOptionalAsMaybe
+ | OptNoVariantInstance
+ | OptVariantInstance
+ | OptPatternAsLambda
+ | OptGenDefs
+ | OptGenCStubs
+ | OptOverloadVariant
+ | OptNoOverloadVariant
+ | OptExpIPointer
+ | OptAnonTLB
+ | OptIntIsInt
+ | OptIntCoercesInPrelude
+ | OptNoEnumMagic
+ | OptGenBitsInstance
+ | OptGenNumInstance
+ | OptLongLongIsInteger
+ | OptUnwrapSingletonStructs
+ | OptIgnoreSourceIfaces
+ | OptNukeEmptyStructs
+ | OptShortHeader
+ | OptJNI
+ | OptCorba
+ | OptCharPtrIsString
+ | OptInlineTypes
+ | OptPointerDefault String
+ | OptOutputDump   String
+ | OptIncludeAsImport
+ | OptExcludeSysIncludes
+ | OptVoidTydefIsAbstract
+ | OptNoWarnMissingMode
+ | OptDon'tTidyDefns
+ | OptNoShareFIDs
+ | OptSmartEnums
+ | OptUseStdDispatch
+ | OptUseIIDIs
+ | OptNoWideStrings
+ | OptIgnoreMethsUpto String
+ | OptOutputModule String
+ | OptClassicNameMangling
+ | OptOutputTlbTo  String
+ | OptOutputHTo    String
+ | OptCppDefine    String
+ | OptIncludeDirs  String
+ | OptIncludeHeader String
+ | OptIncludeCHeader String
+ | OptIncludeCppDirs String
+ | OptOutputFile   String
+ | OptOutputDir    String
+ | OptAsf          String
+ | OptFile         String 
+   deriving ( Eq )
+
+\end{code}
+
+ src/PP.lhs view
@@ -0,0 +1,252 @@+%
+% Derived pretty printing functionality
+%
+
+The @PP@ interface augments the standard @Pretty@ interface
+a little for the task at hand.
+
+\begin{code}
+module PP
+       (
+	 PPDoc
+       , showPPDoc
+       , getPPEnv
+       , setPPEnv
+       
+	 -- additional pp combinators
+	 -- (pinched from GC source.)
+       , vsep
+       , joinedBy
+       , ppDecls
+       , withSemi
+       , ppTuple
+       , ppTupleVert
+       , ppList
+       , ppListVert
+
+       -- re-export of (lifted) Pretty 
+       -- functionality
+       , empty
+       , isEmpty
+       , nest
+       , text
+       , ptext
+       , char
+       , int
+       , integer
+       , float
+       , double
+       , rational
+       , parens
+       , brackets
+       , braces
+       , quotes
+       , doubleQuotes
+       , semi
+       , comma
+       , colon
+       , space
+       , equals
+       , lparen, rparen
+       , lbrack, rbrack
+       , lbrace, rbrace
+       , (<>)
+       , (<+>)
+       , hcat
+       , hsep
+       , ($$)
+       , ($+$)
+       , vcat
+       , sep
+       , cat
+       , fsep
+       , fcat
+       , hang
+       , punctuate
+
+       , render
+	
+       ) where
+
+import qualified Text.PrettyPrint as P
+
+type PPDoc a = a -> P.Doc
+
+showPPDoc ::PPDoc a -> a -> String
+showPPDoc f v = show (f v)
+
+\end{code}
+
+\begin{code}
+vsep :: [PPDoc a] -> PPDoc a
+vsep ds = ds `joinedBy` ($+$)
+
+joinedBy :: [PPDoc a] -> (PPDoc a -> PPDoc a -> PPDoc a) -> PPDoc a
+[] `joinedBy` _    = empty
+xs `joinedBy` sep1 = foldr1 sep1 xs
+
+ppDecls :: [PPDoc a] -> PPDoc a
+ppDecls [] = empty
+ppDecls ls = vsep (punctuate semi ls) <> semi
+
+withSemi :: PPDoc a -> PPDoc a
+withSemi d 
+  | isEmpty d = d
+  | otherwise = d <> semi
+
+ppTuple :: [PPDoc a] -> PPDoc a
+ppTuple ls = parens (hsep (punctuate comma ls))
+
+ppTupleVert :: [PPDoc a] -> PPDoc a
+ppTupleVert []     = ppTuple []
+ppTupleVert (a:as) =
+  vsep (char '(' <+> a : map ((<+>) comma) as) <+> char ')'
+
+ppListVert :: [PPDoc a] -> PPDoc a
+ppListVert []     = brackets empty
+ppListVert [a]    = brackets ( a )
+ppListVert (a:as) =
+  vsep (char '[' <+> a : map ((<+>) comma) as) $$
+  char ']'
+
+ppList :: [PPDoc a] -> PPDoc a
+ppList ls = brackets (hsep (punctuate comma ls))
+
+getPPEnv :: (a -> PPDoc a) -> PPDoc a
+getPPEnv f = \ v -> (f v) v
+
+setPPEnv :: a -> PPDoc a -> PPDoc b
+setPPEnv v f = \ _ -> f v
+\end{code}
+
+Lifting Pretty's functionality up into PPDocs.
+
+\begin{code}
+empty :: PPDoc a
+empty _ = P.empty
+
+isEmpty :: PPDoc a -> Bool
+isEmpty d      = P.isEmpty (d undefined)
+
+nest :: Int -> PPDoc a -> PPDoc a
+nest i d       = \ v -> P.nest i (d v)
+
+text :: String -> PPDoc a
+text nm        = \ _ -> P.text nm
+
+ptext :: String -> PPDoc a
+ptext nm       = \ _ -> P.ptext nm
+
+char :: Char -> PPDoc a
+char c         = \ _ -> P.char c
+
+int :: Int -> PPDoc a
+int i          = \ _ -> P.int i
+
+integer :: Integer -> PPDoc a
+integer i      = \ _ -> P.integer i
+
+float :: Float -> PPDoc a
+float f        = \ _ -> P.float f
+
+double :: Double -> PPDoc a
+double d       = \ _ -> P.double d
+
+rational :: Rational -> PPDoc a
+rational r     = \ _ -> P.rational r
+
+parens :: PPDoc a -> PPDoc a
+parens d       = \ v -> P.parens   (d v)
+
+brackets :: PPDoc a -> PPDoc a
+brackets d     = \ v -> P.brackets (d v)
+
+braces :: PPDoc a -> PPDoc a
+braces d       = \ v -> P.braces (d v)
+
+quotes :: PPDoc a -> PPDoc a
+quotes d       = \ v -> P.quotes (d v)
+
+doubleQuotes :: PPDoc a -> PPDoc a
+doubleQuotes d = \ v -> P.doubleQuotes (d v)
+
+semi :: PPDoc a
+semi           = \ _ -> P.semi
+
+comma :: PPDoc a
+comma          = \ _ -> P.comma
+
+colon :: PPDoc a
+colon          = \ _ -> P.colon
+
+space :: PPDoc a
+space          = \ _ -> P.space
+
+equals :: PPDoc a
+equals         = \ _ -> P.equals
+
+lparen :: PPDoc a
+lparen         = \ _ -> P.lparen
+
+rparen :: PPDoc a
+rparen         = \ _ -> P.rparen
+
+lbrack :: PPDoc a
+lbrack         = \ _ -> P.lbrack
+
+rbrack :: PPDoc a
+rbrack         = \ _ -> P.rbrack
+
+lbrace :: PPDoc a
+lbrace         = \ _ -> P.lbrace
+
+rbrace :: PPDoc a
+rbrace         = \ _ -> P.rbrace
+
+(<>) :: PPDoc a -> PPDoc a -> PPDoc a
+(<>) d1 d2     = \ v -> (P.<>) (d1 v) (d2 v)
+
+(<+>) :: PPDoc a -> PPDoc a -> PPDoc a
+(<+>) d1 d2    = \ v -> (P.<+>) (d1 v) (d2 v)
+
+hcat :: [PPDoc a] -> PPDoc a
+hcat ds        = \ v -> P.hcat (map ($ v) ds)
+
+hsep :: [PPDoc a] -> PPDoc a
+hsep ds        = \ v -> P.hsep (map ($ v) ds)
+
+($$) :: PPDoc a -> PPDoc a -> PPDoc a
+($$) d1 d2     = \ v -> (P.$$)  (d1 v) (d2 v)
+
+($+$) :: PPDoc a -> PPDoc a -> PPDoc a
+($+$) d1 d2    = \ v -> (P.$+$) (d1 v) (d2 v)
+
+vcat :: [PPDoc a] -> PPDoc a
+vcat ds        = \ v -> P.vcat (map ($ v) ds)
+
+sep  :: [PPDoc a] -> PPDoc a
+sep  ds        = \ v -> P.sep (map ($ v) ds)
+
+cat  :: [PPDoc a] -> PPDoc a
+cat  ds        = \ v -> P.cat (map ($ v) ds)
+
+fsep :: [PPDoc a] -> PPDoc a
+fsep ds        = \ v -> P.fsep (map ($ v) ds)
+
+fcat :: [PPDoc a] -> PPDoc a
+fcat ds        = \ v -> P.fcat (map ($ v) ds)
+
+hang :: PPDoc a -> Int -> PPDoc a -> PPDoc a
+hang d1 i d2   = \ v -> P.hang (d1 v) i (d2 v)
+
+render :: PPDoc a -> a -> String
+render d       = \ v -> P.render (d v)
+
+punctuate :: PPDoc a -> [PPDoc a] -> [PPDoc a]
+punctuate _ []     = []
+punctuate p (d:ds) = go d ds
+		   where
+		     go s [] = [s]
+		     go s (e:es) = (s <> p) : go e es
+
+\end{code}
+ src/Parser.hs view
@@ -0,0 +1,8054 @@+{-# OPTIONS -fglasgow-exts -cpp #-}
+-- parser produced by Happy Version 1.13
+
+{-
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+% @(#) $Docid: Jun. 6th 2003  16:54  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+A grammar for IDL, DCE / MS (IDL/ODL) style.
+
+Conflicts:
+   - 1 reduce/reduce conflict due to `default'
+     both being an attribute and a keyword.
+   - 7 shift/reduce conflicts due to the overloading
+     of `const' (t. qualifier and keyword.)
+
+ToDo: 
+  - fix above conflicts.
+
+-}
+module Parser ( parseIDL ) where
+ 
+import LexM
+import Lex
+import IDLToken
+import IDLSyn
+import IDLUtils ( mkFunId, mkMethodId, toCConvAttrib,
+                  mkGNUAttrib, toPackedAttrib, exprType )
+import BasicTypes
+import Literal
+import IO ( hPutStrLn, stderr )
+{-
+BEGIN_GHC_ONLY
+import GlaExts
+END_GHC_ONLY
+-}
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.Exts
+#else
+import GlaExts
+#endif
+
+data HappyAbsSyn 
+	= HappyTerminal IDLToken
+	| HappyErrorToken Int
+	| HappyAbsSyn4 (Either [Defn] [(Name, Bool, [Attribute])])
+	| HappyAbsSyn5 ([Defn])
+	| HappyAbsSyn6 ([(String, Bool, [Attribute])])
+	| HappyAbsSyn7 ((String, Bool, [Attribute] ))
+	| HappyAbsSyn8 (String)
+	| HappyAbsSyn9 (Defn)
+	| HappyAbsSyn13 ([([Attribute], Type, Id)])
+	| HappyAbsSyn14 ([CoClassMember])
+	| HappyAbsSyn15 (CoClassMember)
+	| HappyAbsSyn16 ([Attribute])
+	| HappyAbsSyn18 (Id)
+	| HappyAbsSyn25 (Inherit)
+	| HappyAbsSyn29 ([String])
+	| HappyAbsSyn30 (Type)
+	| HappyAbsSyn34 (Expr)
+	| HappyAbsSyn42 (BinaryOp)
+	| HappyAbsSyn49 (UnaryOp)
+	| HappyAbsSyn54 (Qualifier)
+	| HappyAbsSyn62 (Either [Switch] [Member])
+	| HappyAbsSyn63 ([ Id ])
+	| HappyAbsSyn65 ((Id -> Id))
+	| HappyAbsSyn71 ([[Qualifier]])
+	| HappyAbsSyn72 ([ Qualifier ])
+	| HappyAbsSyn73 ([Member])
+	| HappyAbsSyn74 (Member)
+	| HappyAbsSyn75 (Maybe Id)
+	| HappyAbsSyn77 ([Switch])
+	| HappyAbsSyn78 (Switch)
+	| HappyAbsSyn79 (Maybe SwitchArm)
+	| HappyAbsSyn81 ([CaseLabel])
+	| HappyAbsSyn82 (CaseLabel)
+	| HappyAbsSyn84 ([Expr])
+	| HappyAbsSyn87 ([(Id, [Attribute], Maybe Expr)])
+	| HappyAbsSyn88 ((Id, [Attribute], Maybe Expr))
+	| HappyAbsSyn90 ((Maybe Expr -> Type))
+	| HappyAbsSyn95 ([[Attribute]])
+	| HappyAbsSyn98 (Attribute)
+	| HappyAbsSyn101 ([AttrParam])
+	| HappyAbsSyn103 (AttrParam)
+	| HappyAbsSyn105 (Param)
+	| HappyAbsSyn106 ([Param])
+	| HappyAbsSyn109 ([GNUAttrib])
+	| HappyAbsSyn111 (GNUAttrib)
+	| HappyAbsSyn115 (())
+
+type HappyReduction = 
+	   Int# 
+	-> (IDLToken)
+	-> HappyState (IDLToken) (HappyStk HappyAbsSyn -> LexM(HappyAbsSyn))
+	-> [HappyState (IDLToken) (HappyStk HappyAbsSyn -> LexM(HappyAbsSyn))] 
+	-> HappyStk HappyAbsSyn 
+	-> LexM(HappyAbsSyn)
+
+action_0,
+ action_1,
+ action_2,
+ action_3,
+ action_4,
+ action_5,
+ action_6,
+ action_7,
+ action_8,
+ action_9,
+ action_10,
+ action_11,
+ action_12,
+ action_13,
+ action_14,
+ action_15,
+ action_16,
+ action_17,
+ action_18,
+ action_19,
+ action_20,
+ action_21,
+ action_22,
+ action_23,
+ action_24,
+ action_25,
+ action_26,
+ action_27,
+ action_28,
+ action_29,
+ action_30,
+ action_31,
+ action_32,
+ action_33,
+ action_34,
+ action_35,
+ action_36,
+ action_37,
+ action_38,
+ action_39,
+ action_40,
+ action_41,
+ action_42,
+ action_43,
+ action_44,
+ action_45,
+ action_46,
+ action_47,
+ action_48,
+ action_49,
+ action_50,
+ action_51,
+ action_52,
+ action_53,
+ action_54,
+ action_55,
+ action_56,
+ action_57,
+ action_58,
+ action_59,
+ action_60,
+ action_61,
+ action_62,
+ action_63,
+ action_64,
+ action_65,
+ action_66,
+ action_67,
+ action_68,
+ action_69,
+ action_70,
+ action_71,
+ action_72,
+ action_73,
+ action_74,
+ action_75,
+ action_76,
+ action_77,
+ action_78,
+ action_79,
+ action_80,
+ action_81,
+ action_82,
+ action_83,
+ action_84,
+ action_85,
+ action_86,
+ action_87,
+ action_88,
+ action_89,
+ action_90,
+ action_91,
+ action_92,
+ action_93,
+ action_94,
+ action_95,
+ action_96,
+ action_97,
+ action_98,
+ action_99,
+ action_100,
+ action_101,
+ action_102,
+ action_103,
+ action_104,
+ action_105,
+ action_106,
+ action_107,
+ action_108,
+ action_109,
+ action_110,
+ action_111,
+ action_112,
+ action_113,
+ action_114,
+ action_115,
+ action_116,
+ action_117,
+ action_118,
+ action_119,
+ action_120,
+ action_121,
+ action_122,
+ action_123,
+ action_124,
+ action_125,
+ action_126,
+ action_127,
+ action_128,
+ action_129,
+ action_130,
+ action_131,
+ action_132,
+ action_133,
+ action_134,
+ action_135,
+ action_136,
+ action_137,
+ action_138,
+ action_139,
+ action_140,
+ action_141,
+ action_142,
+ action_143,
+ action_144,
+ action_145,
+ action_146,
+ action_147,
+ action_148,
+ action_149,
+ action_150,
+ action_151,
+ action_152,
+ action_153,
+ action_154,
+ action_155,
+ action_156,
+ action_157,
+ action_158,
+ action_159,
+ action_160,
+ action_161,
+ action_162,
+ action_163,
+ action_164,
+ action_165,
+ action_166,
+ action_167,
+ action_168,
+ action_169,
+ action_170,
+ action_171,
+ action_172,
+ action_173,
+ action_174,
+ action_175,
+ action_176,
+ action_177,
+ action_178,
+ action_179,
+ action_180,
+ action_181,
+ action_182,
+ action_183,
+ action_184,
+ action_185,
+ action_186,
+ action_187,
+ action_188,
+ action_189,
+ action_190,
+ action_191,
+ action_192,
+ action_193,
+ action_194,
+ action_195,
+ action_196,
+ action_197,
+ action_198,
+ action_199,
+ action_200,
+ action_201,
+ action_202,
+ action_203,
+ action_204,
+ action_205,
+ action_206,
+ action_207,
+ action_208,
+ action_209,
+ action_210,
+ action_211,
+ action_212,
+ action_213,
+ action_214,
+ action_215,
+ action_216,
+ action_217,
+ action_218,
+ action_219,
+ action_220,
+ action_221,
+ action_222,
+ action_223,
+ action_224,
+ action_225,
+ action_226,
+ action_227,
+ action_228,
+ action_229,
+ action_230,
+ action_231,
+ action_232,
+ action_233,
+ action_234,
+ action_235,
+ action_236,
+ action_237,
+ action_238,
+ action_239,
+ action_240,
+ action_241,
+ action_242,
+ action_243,
+ action_244,
+ action_245,
+ action_246,
+ action_247,
+ action_248,
+ action_249,
+ action_250,
+ action_251,
+ action_252,
+ action_253,
+ action_254,
+ action_255,
+ action_256,
+ action_257,
+ action_258,
+ action_259,
+ action_260,
+ action_261,
+ action_262,
+ action_263,
+ action_264,
+ action_265,
+ action_266,
+ action_267,
+ action_268,
+ action_269,
+ action_270,
+ action_271,
+ action_272,
+ action_273,
+ action_274,
+ action_275,
+ action_276,
+ action_277,
+ action_278,
+ action_279,
+ action_280,
+ action_281,
+ action_282,
+ action_283,
+ action_284,
+ action_285,
+ action_286,
+ action_287,
+ action_288,
+ action_289,
+ action_290,
+ action_291,
+ action_292,
+ action_293,
+ action_294,
+ action_295,
+ action_296,
+ action_297,
+ action_298,
+ action_299,
+ action_300,
+ action_301,
+ action_302,
+ action_303,
+ action_304,
+ action_305,
+ action_306,
+ action_307,
+ action_308,
+ action_309,
+ action_310,
+ action_311,
+ action_312,
+ action_313,
+ action_314,
+ action_315,
+ action_316,
+ action_317,
+ action_318,
+ action_319,
+ action_320,
+ action_321,
+ action_322,
+ action_323,
+ action_324,
+ action_325,
+ action_326,
+ action_327,
+ action_328,
+ action_329,
+ action_330,
+ action_331,
+ action_332,
+ action_333,
+ action_334,
+ action_335,
+ action_336,
+ action_337,
+ action_338,
+ action_339,
+ action_340,
+ action_341,
+ action_342,
+ action_343,
+ action_344,
+ action_345,
+ action_346,
+ action_347,
+ action_348,
+ action_349,
+ action_350,
+ action_351,
+ action_352,
+ action_353,
+ action_354,
+ action_355,
+ action_356,
+ action_357,
+ action_358,
+ action_359,
+ action_360,
+ action_361,
+ action_362,
+ action_363,
+ action_364,
+ action_365,
+ action_366,
+ action_367,
+ action_368,
+ action_369,
+ action_370,
+ action_371,
+ action_372,
+ action_373,
+ action_374,
+ action_375,
+ action_376,
+ action_377,
+ action_378,
+ action_379,
+ action_380,
+ action_381,
+ action_382,
+ action_383,
+ action_384,
+ action_385,
+ action_386,
+ action_387,
+ action_388,
+ action_389,
+ action_390,
+ action_391,
+ action_392,
+ action_393,
+ action_394,
+ action_395,
+ action_396,
+ action_397,
+ action_398,
+ action_399,
+ action_400,
+ action_401,
+ action_402,
+ action_403,
+ action_404,
+ action_405,
+ action_406,
+ action_407,
+ action_408,
+ action_409,
+ action_410,
+ action_411,
+ action_412,
+ action_413,
+ action_414,
+ action_415,
+ action_416,
+ action_417,
+ action_418,
+ action_419,
+ action_420,
+ action_421,
+ action_422,
+ action_423,
+ action_424,
+ action_425,
+ action_426,
+ action_427,
+ action_428,
+ action_429,
+ action_430,
+ action_431,
+ action_432,
+ action_433,
+ action_434,
+ action_435,
+ action_436,
+ action_437,
+ action_438,
+ action_439,
+ action_440,
+ action_441,
+ action_442,
+ action_443,
+ action_444,
+ action_445,
+ action_446,
+ action_447,
+ action_448,
+ action_449,
+ action_450,
+ action_451,
+ action_452,
+ action_453,
+ action_454,
+ action_455,
+ action_456,
+ action_457,
+ action_458,
+ action_459,
+ action_460,
+ action_461,
+ action_462,
+ action_463,
+ action_464,
+ action_465,
+ action_466,
+ action_467,
+ action_468,
+ action_469,
+ action_470,
+ action_471,
+ action_472,
+ action_473,
+ action_474,
+ action_475,
+ action_476,
+ action_477,
+ action_478,
+ action_479,
+ action_480,
+ action_481,
+ action_482,
+ action_483,
+ action_484,
+ action_485,
+ action_486,
+ action_487,
+ action_488,
+ action_489,
+ action_490,
+ action_491,
+ action_492,
+ action_493,
+ action_494,
+ action_495,
+ action_496,
+ action_497,
+ action_498,
+ action_499,
+ action_500,
+ action_501,
+ action_502,
+ action_503,
+ action_504,
+ action_505,
+ action_506,
+ action_507,
+ action_508,
+ action_509,
+ action_510,
+ action_511,
+ action_512,
+ action_513,
+ action_514,
+ action_515,
+ action_516,
+ action_517,
+ action_518,
+ action_519,
+ action_520,
+ action_521,
+ action_522,
+ action_523,
+ action_524,
+ action_525,
+ action_526,
+ action_527,
+ action_528,
+ action_529,
+ action_530,
+ action_531,
+ action_532,
+ action_533,
+ action_534,
+ action_535,
+ action_536,
+ action_537,
+ action_538,
+ action_539,
+ action_540,
+ action_541,
+ action_542,
+ action_543,
+ action_544,
+ action_545,
+ action_546,
+ action_547,
+ action_548,
+ action_549,
+ action_550,
+ action_551,
+ action_552,
+ action_553,
+ action_554,
+ action_555,
+ action_556,
+ action_557,
+ action_558,
+ action_559,
+ action_560,
+ action_561,
+ action_562,
+ action_563,
+ action_564,
+ action_565,
+ action_566,
+ action_567,
+ action_568,
+ action_569,
+ action_570,
+ action_571,
+ action_572,
+ action_573,
+ action_574,
+ action_575,
+ action_576,
+ action_577,
+ action_578,
+ action_579,
+ action_580,
+ action_581,
+ action_582,
+ action_583,
+ action_584,
+ action_585,
+ action_586,
+ action_587,
+ action_588,
+ action_589,
+ action_590,
+ action_591,
+ action_592,
+ action_593,
+ action_594,
+ action_595,
+ action_596,
+ action_597 :: Int# -> HappyReduction
+
+happyReduce_1,
+ happyReduce_2,
+ happyReduce_3,
+ happyReduce_4,
+ happyReduce_5,
+ happyReduce_6,
+ happyReduce_7,
+ happyReduce_8,
+ happyReduce_9,
+ happyReduce_10,
+ happyReduce_11,
+ happyReduce_12,
+ happyReduce_13,
+ happyReduce_14,
+ happyReduce_15,
+ happyReduce_16,
+ happyReduce_17,
+ happyReduce_18,
+ happyReduce_19,
+ happyReduce_20,
+ happyReduce_21,
+ happyReduce_22,
+ happyReduce_23,
+ happyReduce_24,
+ happyReduce_25,
+ happyReduce_26,
+ happyReduce_27,
+ happyReduce_28,
+ happyReduce_29,
+ happyReduce_30,
+ happyReduce_31,
+ happyReduce_32,
+ happyReduce_33,
+ happyReduce_34,
+ happyReduce_35,
+ happyReduce_36,
+ happyReduce_37,
+ happyReduce_38,
+ happyReduce_39,
+ happyReduce_40,
+ happyReduce_41,
+ happyReduce_42,
+ happyReduce_43,
+ happyReduce_44,
+ happyReduce_45,
+ happyReduce_46,
+ happyReduce_47,
+ happyReduce_48,
+ happyReduce_49,
+ happyReduce_50,
+ happyReduce_51,
+ happyReduce_52,
+ happyReduce_53,
+ happyReduce_54,
+ happyReduce_55,
+ happyReduce_56,
+ happyReduce_57,
+ happyReduce_58,
+ happyReduce_59,
+ happyReduce_60,
+ happyReduce_61,
+ happyReduce_62,
+ happyReduce_63,
+ happyReduce_64,
+ happyReduce_65,
+ happyReduce_66,
+ happyReduce_67,
+ happyReduce_68,
+ happyReduce_69,
+ happyReduce_70,
+ happyReduce_71,
+ happyReduce_72,
+ happyReduce_73,
+ happyReduce_74,
+ happyReduce_75,
+ happyReduce_76,
+ happyReduce_77,
+ happyReduce_78,
+ happyReduce_79,
+ happyReduce_80,
+ happyReduce_81,
+ happyReduce_82,
+ happyReduce_83,
+ happyReduce_84,
+ happyReduce_85,
+ happyReduce_86,
+ happyReduce_87,
+ happyReduce_88,
+ happyReduce_89,
+ happyReduce_90,
+ happyReduce_91,
+ happyReduce_92,
+ happyReduce_93,
+ happyReduce_94,
+ happyReduce_95,
+ happyReduce_96,
+ happyReduce_97,
+ happyReduce_98,
+ happyReduce_99,
+ happyReduce_100,
+ happyReduce_101,
+ happyReduce_102,
+ happyReduce_103,
+ happyReduce_104,
+ happyReduce_105,
+ happyReduce_106,
+ happyReduce_107,
+ happyReduce_108,
+ happyReduce_109,
+ happyReduce_110,
+ happyReduce_111,
+ happyReduce_112,
+ happyReduce_113,
+ happyReduce_114,
+ happyReduce_115,
+ happyReduce_116,
+ happyReduce_117,
+ happyReduce_118,
+ happyReduce_119,
+ happyReduce_120,
+ happyReduce_121,
+ happyReduce_122,
+ happyReduce_123,
+ happyReduce_124,
+ happyReduce_125,
+ happyReduce_126,
+ happyReduce_127,
+ happyReduce_128,
+ happyReduce_129,
+ happyReduce_130,
+ happyReduce_131,
+ happyReduce_132,
+ happyReduce_133,
+ happyReduce_134,
+ happyReduce_135,
+ happyReduce_136,
+ happyReduce_137,
+ happyReduce_138,
+ happyReduce_139,
+ happyReduce_140,
+ happyReduce_141,
+ happyReduce_142,
+ happyReduce_143,
+ happyReduce_144,
+ happyReduce_145,
+ happyReduce_146,
+ happyReduce_147,
+ happyReduce_148,
+ happyReduce_149,
+ happyReduce_150,
+ happyReduce_151,
+ happyReduce_152,
+ happyReduce_153,
+ happyReduce_154,
+ happyReduce_155,
+ happyReduce_156,
+ happyReduce_157,
+ happyReduce_158,
+ happyReduce_159,
+ happyReduce_160,
+ happyReduce_161,
+ happyReduce_162,
+ happyReduce_163,
+ happyReduce_164,
+ happyReduce_165,
+ happyReduce_166,
+ happyReduce_167,
+ happyReduce_168,
+ happyReduce_169,
+ happyReduce_170,
+ happyReduce_171,
+ happyReduce_172,
+ happyReduce_173,
+ happyReduce_174,
+ happyReduce_175,
+ happyReduce_176,
+ happyReduce_177,
+ happyReduce_178,
+ happyReduce_179,
+ happyReduce_180,
+ happyReduce_181,
+ happyReduce_182,
+ happyReduce_183,
+ happyReduce_184,
+ happyReduce_185,
+ happyReduce_186,
+ happyReduce_187,
+ happyReduce_188,
+ happyReduce_189,
+ happyReduce_190,
+ happyReduce_191,
+ happyReduce_192,
+ happyReduce_193,
+ happyReduce_194,
+ happyReduce_195,
+ happyReduce_196,
+ happyReduce_197,
+ happyReduce_198,
+ happyReduce_199,
+ happyReduce_200,
+ happyReduce_201,
+ happyReduce_202,
+ happyReduce_203,
+ happyReduce_204,
+ happyReduce_205,
+ happyReduce_206,
+ happyReduce_207,
+ happyReduce_208,
+ happyReduce_209,
+ happyReduce_210,
+ happyReduce_211,
+ happyReduce_212,
+ happyReduce_213,
+ happyReduce_214,
+ happyReduce_215,
+ happyReduce_216,
+ happyReduce_217,
+ happyReduce_218,
+ happyReduce_219,
+ happyReduce_220,
+ happyReduce_221,
+ happyReduce_222,
+ happyReduce_223,
+ happyReduce_224,
+ happyReduce_225,
+ happyReduce_226,
+ happyReduce_227,
+ happyReduce_228,
+ happyReduce_229,
+ happyReduce_230,
+ happyReduce_231,
+ happyReduce_232,
+ happyReduce_233,
+ happyReduce_234,
+ happyReduce_235,
+ happyReduce_236,
+ happyReduce_237,
+ happyReduce_238,
+ happyReduce_239,
+ happyReduce_240,
+ happyReduce_241,
+ happyReduce_242,
+ happyReduce_243,
+ happyReduce_244,
+ happyReduce_245,
+ happyReduce_246,
+ happyReduce_247,
+ happyReduce_248,
+ happyReduce_249,
+ happyReduce_250,
+ happyReduce_251,
+ happyReduce_252,
+ happyReduce_253,
+ happyReduce_254,
+ happyReduce_255,
+ happyReduce_256,
+ happyReduce_257,
+ happyReduce_258,
+ happyReduce_259,
+ happyReduce_260,
+ happyReduce_261,
+ happyReduce_262,
+ happyReduce_263,
+ happyReduce_264,
+ happyReduce_265,
+ happyReduce_266,
+ happyReduce_267,
+ happyReduce_268,
+ happyReduce_269,
+ happyReduce_270,
+ happyReduce_271,
+ happyReduce_272,
+ happyReduce_273,
+ happyReduce_274,
+ happyReduce_275,
+ happyReduce_276,
+ happyReduce_277,
+ happyReduce_278,
+ happyReduce_279,
+ happyReduce_280,
+ happyReduce_281,
+ happyReduce_282,
+ happyReduce_283,
+ happyReduce_284,
+ happyReduce_285,
+ happyReduce_286,
+ happyReduce_287,
+ happyReduce_288,
+ happyReduce_289,
+ happyReduce_290,
+ happyReduce_291,
+ happyReduce_292,
+ happyReduce_293,
+ happyReduce_294,
+ happyReduce_295,
+ happyReduce_296,
+ happyReduce_297,
+ happyReduce_298,
+ happyReduce_299,
+ happyReduce_300,
+ happyReduce_301,
+ happyReduce_302,
+ happyReduce_303,
+ happyReduce_304,
+ happyReduce_305,
+ happyReduce_306,
+ happyReduce_307,
+ happyReduce_308,
+ happyReduce_309,
+ happyReduce_310,
+ happyReduce_311,
+ happyReduce_312,
+ happyReduce_313,
+ happyReduce_314,
+ happyReduce_315,
+ happyReduce_316,
+ happyReduce_317,
+ happyReduce_318,
+ happyReduce_319,
+ happyReduce_320,
+ happyReduce_321,
+ happyReduce_322,
+ happyReduce_323,
+ happyReduce_324,
+ happyReduce_325,
+ happyReduce_326,
+ happyReduce_327,
+ happyReduce_328,
+ happyReduce_329,
+ happyReduce_330,
+ happyReduce_331,
+ happyReduce_332,
+ happyReduce_333,
+ happyReduce_334,
+ happyReduce_335,
+ happyReduce_336,
+ happyReduce_337,
+ happyReduce_338,
+ happyReduce_339,
+ happyReduce_340,
+ happyReduce_341,
+ happyReduce_342,
+ happyReduce_343,
+ happyReduce_344,
+ happyReduce_345,
+ happyReduce_346,
+ happyReduce_347,
+ happyReduce_348,
+ happyReduce_349,
+ happyReduce_350,
+ happyReduce_351,
+ happyReduce_352,
+ happyReduce_353,
+ happyReduce_354,
+ happyReduce_355,
+ happyReduce_356,
+ happyReduce_357,
+ happyReduce_358,
+ happyReduce_359 :: HappyReduction
+
+action_0 (130#) = happyShift action_4
+action_0 (4#) = happyGoto action_3
+action_0 (5#) = happyGoto action_2
+action_0 x = happyTcHack x happyReduce_3
+
+action_1 (5#) = happyGoto action_2
+action_1 x = happyTcHack x happyFail
+
+action_2 (1#) = happyShift action_36
+action_2 (118#) = happyShift action_37
+action_2 (119#) = happyShift action_38
+action_2 (128#) = happyShift action_39
+action_2 (144#) = happyReduce_344
+action_2 (145#) = happyReduce_344
+action_2 (146#) = happyShift action_40
+action_2 (147#) = happyShift action_41
+action_2 (148#) = happyShift action_42
+action_2 (149#) = happyShift action_43
+action_2 (150#) = happyShift action_44
+action_2 (151#) = happyShift action_45
+action_2 (152#) = happyShift action_46
+action_2 (153#) = happyShift action_47
+action_2 (154#) = happyShift action_48
+action_2 (155#) = happyShift action_49
+action_2 (156#) = happyShift action_50
+action_2 (157#) = happyShift action_51
+action_2 (158#) = happyShift action_52
+action_2 (159#) = happyShift action_53
+action_2 (163#) = happyShift action_54
+action_2 (168#) = happyShift action_55
+action_2 (171#) = happyShift action_56
+action_2 (176#) = happyShift action_57
+action_2 (177#) = happyShift action_58
+action_2 (178#) = happyShift action_59
+action_2 (179#) = happyShift action_60
+action_2 (183#) = happyShift action_61
+action_2 (184#) = happyShift action_62
+action_2 (187#) = happyShift action_63
+action_2 (188#) = happyShift action_64
+action_2 (189#) = happyShift action_65
+action_2 (190#) = happyShift action_66
+action_2 (191#) = happyShift action_67
+action_2 (192#) = happyShift action_68
+action_2 (193#) = happyShift action_69
+action_2 (194#) = happyShift action_70
+action_2 (195#) = happyShift action_71
+action_2 (196#) = happyShift action_72
+action_2 (197#) = happyShift action_73
+action_2 (199#) = happyReduce_1
+action_2 (9#) = happyGoto action_6
+action_2 (10#) = happyGoto action_7
+action_2 (11#) = happyGoto action_8
+action_2 (12#) = happyGoto action_9
+action_2 (17#) = happyGoto action_10
+action_2 (18#) = happyGoto action_11
+action_2 (19#) = happyGoto action_12
+action_2 (20#) = happyGoto action_13
+action_2 (21#) = happyGoto action_14
+action_2 (26#) = happyGoto action_15
+action_2 (27#) = happyGoto action_16
+action_2 (28#) = happyGoto action_17
+action_2 (31#) = happyGoto action_18
+action_2 (32#) = happyGoto action_19
+action_2 (51#) = happyGoto action_20
+action_2 (53#) = happyGoto action_21
+action_2 (55#) = happyGoto action_22
+action_2 (58#) = happyGoto action_23
+action_2 (59#) = happyGoto action_24
+action_2 (60#) = happyGoto action_25
+action_2 (61#) = happyGoto action_26
+action_2 (86#) = happyGoto action_27
+action_2 (89#) = happyGoto action_28
+action_2 (90#) = happyGoto action_29
+action_2 (93#) = happyGoto action_30
+action_2 (96#) = happyGoto action_31
+action_2 (104#) = happyGoto action_32
+action_2 (109#) = happyGoto action_33
+action_2 (110#) = happyGoto action_34
+action_2 (111#) = happyGoto action_35
+action_2 x = happyTcHack x happyFail
+
+action_3 (199#) = happyAccept
+action_3 x = happyTcHack x happyFail
+
+action_4 (6#) = happyGoto action_5
+action_4 x = happyTcHack x happyReduce_5
+
+action_5 (146#) = happyShift action_175
+action_5 (176#) = happyShift action_176
+action_5 (7#) = happyGoto action_173
+action_5 (8#) = happyGoto action_174
+action_5 x = happyTcHack x happyReduce_2
+
+action_6 x = happyTcHack x happyReduce_4
+
+action_7 (1#) = happyShift action_166
+action_7 (117#) = happyShift action_167
+action_7 (115#) = happyGoto action_172
+action_7 x = happyTcHack x happyFail
+
+action_8 x = happyTcHack x happyReduce_20
+
+action_9 x = happyTcHack x happyReduce_24
+
+action_10 x = happyTcHack x happyReduce_21
+
+action_11 (122#) = happyReduce_60
+action_11 (124#) = happyShift action_171
+action_11 (25#) = happyGoto action_170
+action_11 x = happyTcHack x happyReduce_41
+
+action_12 (122#) = happyShift action_169
+action_12 x = happyTcHack x happyFail
+
+action_13 (1#) = happyShift action_166
+action_13 (117#) = happyShift action_167
+action_13 (115#) = happyGoto action_168
+action_13 x = happyTcHack x happyFail
+
+action_14 (1#) = happyShift action_166
+action_14 (117#) = happyShift action_167
+action_14 (115#) = happyGoto action_165
+action_14 x = happyTcHack x happyFail
+
+action_15 (117#) = happyShift action_164
+action_15 x = happyTcHack x happyFail
+
+action_16 x = happyTcHack x happyReduce_18
+
+action_17 x = happyTcHack x happyReduce_16
+
+action_18 (153#) = happyShift action_161
+action_18 (154#) = happyShift action_162
+action_18 (155#) = happyShift action_163
+action_18 x = happyTcHack x happyReduce_99
+
+action_19 x = happyTcHack x happyReduce_184
+
+action_20 (117#) = happyShift action_160
+action_20 x = happyTcHack x happyFail
+
+action_21 (168#) = happyShift action_159
+action_21 x = happyTcHack x happyReduce_327
+
+action_22 (128#) = happyShift action_157
+action_22 (129#) = happyShift action_158
+action_22 (54#) = happyGoto action_156
+action_22 x = happyTcHack x happyReduce_176
+
+action_23 x = happyTcHack x happyReduce_167
+
+action_24 (120#) = happyReduce_198
+action_24 (124#) = happyReduce_198
+action_24 (128#) = happyReduce_198
+action_24 (129#) = happyReduce_198
+action_24 (146#) = happyReduce_198
+action_24 (168#) = happyReduce_198
+action_24 (172#) = happyReduce_198
+action_24 (175#) = happyReduce_198
+action_24 (176#) = happyReduce_198
+action_24 (181#) = happyReduce_198
+action_24 (193#) = happyReduce_198
+action_24 x = happyTcHack x happyReduce_208
+
+action_25 x = happyTcHack x happyReduce_210
+
+action_26 x = happyTcHack x happyReduce_211
+
+action_27 (120#) = happyReduce_199
+action_27 (124#) = happyReduce_199
+action_27 (128#) = happyReduce_199
+action_27 (129#) = happyReduce_199
+action_27 (146#) = happyReduce_199
+action_27 (168#) = happyReduce_199
+action_27 (172#) = happyReduce_199
+action_27 (175#) = happyReduce_199
+action_27 (176#) = happyReduce_199
+action_27 (181#) = happyReduce_199
+action_27 (193#) = happyReduce_199
+action_27 x = happyTcHack x happyReduce_209
+
+action_28 x = happyTcHack x happyReduce_328
+
+action_29 (164#) = happyShift action_155
+action_29 x = happyTcHack x happyReduce_295
+
+action_30 x = happyTcHack x happyReduce_28
+
+action_31 (1#) = happyShift action_36
+action_31 (118#) = happyShift action_37
+action_31 (119#) = happyShift action_38
+action_31 (128#) = happyShift action_153
+action_31 (146#) = happyShift action_40
+action_31 (147#) = happyShift action_41
+action_31 (148#) = happyShift action_42
+action_31 (149#) = happyShift action_43
+action_31 (150#) = happyShift action_44
+action_31 (151#) = happyShift action_45
+action_31 (152#) = happyShift action_46
+action_31 (153#) = happyShift action_47
+action_31 (154#) = happyShift action_48
+action_31 (155#) = happyShift action_49
+action_31 (156#) = happyShift action_50
+action_31 (157#) = happyShift action_51
+action_31 (158#) = happyShift action_52
+action_31 (159#) = happyShift action_53
+action_31 (163#) = happyShift action_54
+action_31 (171#) = happyShift action_56
+action_31 (176#) = happyShift action_57
+action_31 (177#) = happyShift action_154
+action_31 (178#) = happyShift action_59
+action_31 (179#) = happyShift action_60
+action_31 (183#) = happyShift action_61
+action_31 (184#) = happyShift action_62
+action_31 (197#) = happyShift action_73
+action_31 (11#) = happyGoto action_151
+action_31 (12#) = happyGoto action_9
+action_31 (17#) = happyGoto action_10
+action_31 (18#) = happyGoto action_11
+action_31 (19#) = happyGoto action_12
+action_31 (31#) = happyGoto action_18
+action_31 (32#) = happyGoto action_19
+action_31 (53#) = happyGoto action_21
+action_31 (55#) = happyGoto action_22
+action_31 (58#) = happyGoto action_152
+action_31 (59#) = happyGoto action_24
+action_31 (60#) = happyGoto action_25
+action_31 (61#) = happyGoto action_26
+action_31 (86#) = happyGoto action_27
+action_31 (89#) = happyGoto action_28
+action_31 (90#) = happyGoto action_29
+action_31 (93#) = happyGoto action_30
+action_31 (104#) = happyGoto action_32
+action_31 x = happyTcHack x happyFail
+
+action_32 (120#) = happyShift action_148
+action_32 (124#) = happyShift action_104
+action_32 (146#) = happyShift action_105
+action_32 (172#) = happyShift action_106
+action_32 (175#) = happyShift action_149
+action_32 (176#) = happyShift action_86
+action_32 (181#) = happyShift action_150
+action_32 (193#) = happyShift action_69
+action_32 (64#) = happyGoto action_139
+action_32 (65#) = happyGoto action_140
+action_32 (66#) = happyGoto action_141
+action_32 (67#) = happyGoto action_142
+action_32 (68#) = happyGoto action_143
+action_32 (69#) = happyGoto action_144
+action_32 (70#) = happyGoto action_145
+action_32 (71#) = happyGoto action_146
+action_32 (110#) = happyGoto action_147
+action_32 (111#) = happyGoto action_35
+action_32 (114#) = happyGoto action_102
+action_32 x = happyTcHack x happyFail
+
+action_33 (144#) = happyShift action_137
+action_33 (145#) = happyShift action_138
+action_33 x = happyTcHack x happyFail
+
+action_34 (193#) = happyShift action_69
+action_34 (111#) = happyGoto action_136
+action_34 x = happyTcHack x happyReduce_345
+
+action_35 x = happyTcHack x happyReduce_346
+
+action_36 x = happyTcHack x happyReduce_200
+
+action_37 (176#) = happyShift action_86
+action_37 (114#) = happyGoto action_135
+action_37 x = happyTcHack x happyFail
+
+action_38 (146#) = happyShift action_133
+action_38 (147#) = happyShift action_134
+action_38 (176#) = happyShift action_86
+action_38 (114#) = happyGoto action_132
+action_38 x = happyTcHack x happyFail
+
+action_39 (1#) = happyShift action_122
+action_39 (146#) = happyShift action_123
+action_39 (147#) = happyShift action_124
+action_39 (148#) = happyShift action_125
+action_39 (149#) = happyShift action_43
+action_39 (150#) = happyShift action_44
+action_39 (151#) = happyShift action_45
+action_39 (152#) = happyShift action_46
+action_39 (153#) = happyShift action_47
+action_39 (154#) = happyShift action_126
+action_39 (155#) = happyShift action_127
+action_39 (156#) = happyShift action_128
+action_39 (157#) = happyShift action_129
+action_39 (171#) = happyShift action_130
+action_39 (176#) = happyShift action_131
+action_39 (183#) = happyShift action_61
+action_39 (184#) = happyShift action_62
+action_39 (30#) = happyGoto action_118
+action_39 (31#) = happyGoto action_119
+action_39 (32#) = happyGoto action_120
+action_39 (89#) = happyGoto action_121
+action_39 (90#) = happyGoto action_29
+action_39 x = happyTcHack x happyFail
+
+action_40 x = happyTcHack x happyReduce_195
+
+action_41 x = happyTcHack x happyReduce_196
+
+action_42 x = happyTcHack x happyReduce_181
+
+action_43 x = happyTcHack x happyReduce_94
+
+action_44 (150#) = happyShift action_117
+action_44 x = happyTcHack x happyReduce_95
+
+action_45 x = happyTcHack x happyReduce_97
+
+action_46 x = happyTcHack x happyReduce_98
+
+action_47 x = happyTcHack x happyReduce_101
+
+action_48 (128#) = happyShift action_116
+action_48 (146#) = happyShift action_111
+action_48 (147#) = happyShift action_112
+action_48 (148#) = happyShift action_113
+action_48 (149#) = happyShift action_43
+action_48 (150#) = happyShift action_44
+action_48 (151#) = happyShift action_45
+action_48 (152#) = happyShift action_46
+action_48 (153#) = happyShift action_47
+action_48 (156#) = happyShift action_114
+action_48 (31#) = happyGoto action_107
+action_48 (32#) = happyGoto action_108
+action_48 (56#) = happyGoto action_115
+action_48 x = happyTcHack x happyReduce_187
+
+action_49 (128#) = happyShift action_110
+action_49 (146#) = happyShift action_111
+action_49 (147#) = happyShift action_112
+action_49 (148#) = happyShift action_113
+action_49 (149#) = happyShift action_43
+action_49 (150#) = happyShift action_44
+action_49 (151#) = happyShift action_45
+action_49 (152#) = happyShift action_46
+action_49 (153#) = happyShift action_47
+action_49 (156#) = happyShift action_114
+action_49 (31#) = happyGoto action_107
+action_49 (32#) = happyGoto action_108
+action_49 (56#) = happyGoto action_109
+action_49 x = happyTcHack x happyReduce_186
+
+action_50 x = happyTcHack x happyReduce_182
+
+action_51 x = happyTcHack x happyReduce_183
+
+action_52 (122#) = happyShift action_103
+action_52 (124#) = happyShift action_104
+action_52 (146#) = happyShift action_105
+action_52 (172#) = happyShift action_106
+action_52 (176#) = happyShift action_86
+action_52 (67#) = happyGoto action_101
+action_52 (114#) = happyGoto action_102
+action_52 x = happyTcHack x happyFail
+
+action_53 (176#) = happyShift action_86
+action_53 (75#) = happyGoto action_99
+action_53 (114#) = happyGoto action_100
+action_53 x = happyTcHack x happyReduce_257
+
+action_54 (122#) = happyShift action_98
+action_54 (176#) = happyShift action_86
+action_54 (114#) = happyGoto action_97
+action_54 x = happyTcHack x happyFail
+
+action_55 (169#) = happyShift action_94
+action_55 (172#) = happyShift action_95
+action_55 (176#) = happyShift action_86
+action_55 (183#) = happyShift action_96
+action_55 (97#) = happyGoto action_91
+action_55 (98#) = happyGoto action_92
+action_55 (114#) = happyGoto action_93
+action_55 x = happyTcHack x happyFail
+
+action_56 x = happyTcHack x happyReduce_185
+
+action_57 x = happyTcHack x happyReduce_194
+
+action_58 (146#) = happyShift action_90
+action_58 (176#) = happyShift action_86
+action_58 (114#) = happyGoto action_89
+action_58 x = happyTcHack x happyFail
+
+action_59 (146#) = happyShift action_88
+action_59 (176#) = happyShift action_86
+action_59 (114#) = happyGoto action_87
+action_59 x = happyTcHack x happyFail
+
+action_60 (176#) = happyShift action_86
+action_60 (114#) = happyGoto action_85
+action_60 x = happyTcHack x happyFail
+
+action_61 x = happyTcHack x happyReduce_296
+
+action_62 x = happyTcHack x happyReduce_297
+
+action_63 (120#) = happyShift action_84
+action_63 x = happyTcHack x happyFail
+
+action_64 (120#) = happyShift action_83
+action_64 x = happyTcHack x happyFail
+
+action_65 x = happyTcHack x happyReduce_50
+
+action_66 (120#) = happyShift action_82
+action_66 x = happyTcHack x happyFail
+
+action_67 x = happyTcHack x happyReduce_66
+
+action_68 x = happyTcHack x happyReduce_67
+
+action_69 (120#) = happyShift action_81
+action_69 x = happyTcHack x happyFail
+
+action_70 (174#) = happyShift action_80
+action_70 (29#) = happyGoto action_79
+action_70 x = happyTcHack x happyFail
+
+action_71 x = happyTcHack x happyReduce_65
+
+action_72 (176#) = happyShift action_78
+action_72 x = happyTcHack x happyFail
+
+action_73 (1#) = happyShift action_36
+action_73 (146#) = happyShift action_40
+action_73 (147#) = happyShift action_41
+action_73 (148#) = happyShift action_42
+action_73 (149#) = happyShift action_43
+action_73 (150#) = happyShift action_44
+action_73 (151#) = happyShift action_45
+action_73 (152#) = happyShift action_46
+action_73 (153#) = happyShift action_47
+action_73 (154#) = happyShift action_48
+action_73 (155#) = happyShift action_49
+action_73 (156#) = happyShift action_50
+action_73 (157#) = happyShift action_51
+action_73 (158#) = happyShift action_52
+action_73 (159#) = happyShift action_53
+action_73 (163#) = happyShift action_54
+action_73 (171#) = happyShift action_56
+action_73 (176#) = happyShift action_57
+action_73 (197#) = happyShift action_73
+action_73 (31#) = happyGoto action_18
+action_73 (32#) = happyGoto action_19
+action_73 (55#) = happyGoto action_74
+action_73 (57#) = happyGoto action_75
+action_73 (59#) = happyGoto action_76
+action_73 (60#) = happyGoto action_25
+action_73 (61#) = happyGoto action_26
+action_73 (86#) = happyGoto action_77
+action_73 x = happyTcHack x happyFail
+
+action_74 x = happyTcHack x happyReduce_206
+
+action_75 (121#) = happyShift action_274
+action_75 (181#) = happyShift action_275
+action_75 x = happyTcHack x happyFail
+
+action_76 x = happyTcHack x happyReduce_198
+
+action_77 x = happyTcHack x happyReduce_199
+
+action_78 (120#) = happyShift action_195
+action_78 (141#) = happyShift action_196
+action_78 (142#) = happyShift action_197
+action_78 (170#) = happyShift action_198
+action_78 (173#) = happyShift action_199
+action_78 (174#) = happyShift action_200
+action_78 (176#) = happyShift action_86
+action_78 (180#) = happyShift action_201
+action_78 (182#) = happyShift action_202
+action_78 (34#) = happyGoto action_264
+action_78 (35#) = happyGoto action_265
+action_78 (36#) = happyGoto action_266
+action_78 (37#) = happyGoto action_267
+action_78 (38#) = happyGoto action_268
+action_78 (39#) = happyGoto action_269
+action_78 (40#) = happyGoto action_270
+action_78 (41#) = happyGoto action_271
+action_78 (43#) = happyGoto action_272
+action_78 (44#) = happyGoto action_273
+action_78 (45#) = happyGoto action_188
+action_78 (46#) = happyGoto action_189
+action_78 (47#) = happyGoto action_190
+action_78 (48#) = happyGoto action_191
+action_78 (49#) = happyGoto action_192
+action_78 (50#) = happyGoto action_193
+action_78 (114#) = happyGoto action_194
+action_78 x = happyTcHack x happyFail
+
+action_79 x = happyTcHack x happyReduce_63
+
+action_80 (125#) = happyShift action_263
+action_80 x = happyTcHack x happyReduce_69
+
+action_81 (120#) = happyShift action_262
+action_81 x = happyTcHack x happyFail
+
+action_82 (174#) = happyShift action_261
+action_82 x = happyTcHack x happyFail
+
+action_83 (174#) = happyShift action_260
+action_83 x = happyTcHack x happyFail
+
+action_84 (174#) = happyShift action_259
+action_84 x = happyTcHack x happyFail
+
+action_85 (122#) = happyShift action_258
+action_85 x = happyTcHack x happyFail
+
+action_86 x = happyTcHack x happyReduce_355
+
+action_87 (122#) = happyShift action_257
+action_87 x = happyTcHack x happyFail
+
+action_88 (122#) = happyShift action_256
+action_88 x = happyTcHack x happyFail
+
+action_89 (117#) = happyShift action_255
+action_89 x = happyTcHack x happyReduce_46
+
+action_90 x = happyTcHack x happyReduce_47
+
+action_91 (125#) = happyShift action_254
+action_91 (116#) = happyGoto action_253
+action_91 x = happyTcHack x happyReduce_358
+
+action_92 x = happyTcHack x happyReduce_307
+
+action_93 (120#) = happyShift action_252
+action_93 (101#) = happyGoto action_251
+action_93 x = happyTcHack x happyReduce_316
+
+action_94 x = happyTcHack x happyReduce_305
+
+action_95 x = happyTcHack x happyReduce_311
+
+action_96 x = happyTcHack x happyReduce_310
+
+action_97 (122#) = happyShift action_250
+action_97 x = happyTcHack x happyReduce_287
+
+action_98 (168#) = happyShift action_55
+action_98 (176#) = happyShift action_86
+action_98 (87#) = happyGoto action_246
+action_98 (88#) = happyGoto action_247
+action_98 (96#) = happyGoto action_248
+action_98 (114#) = happyGoto action_249
+action_98 x = happyTcHack x happyFail
+
+action_99 (122#) = happyShift action_244
+action_99 (160#) = happyShift action_245
+action_99 x = happyTcHack x happyFail
+
+action_100 (122#) = happyReduce_258
+action_100 (160#) = happyReduce_258
+action_100 (193#) = happyShift action_69
+action_100 (109#) = happyGoto action_243
+action_100 (110#) = happyGoto action_34
+action_100 (111#) = happyGoto action_35
+action_100 x = happyTcHack x happyReduce_344
+
+action_101 (122#) = happyShift action_242
+action_101 x = happyTcHack x happyReduce_214
+
+action_102 (124#) = happyShift action_241
+action_102 x = happyTcHack x happyReduce_232
+
+action_103 (168#) = happyShift action_55
+action_103 (73#) = happyGoto action_238
+action_103 (74#) = happyGoto action_239
+action_103 (94#) = happyGoto action_240
+action_103 (95#) = happyGoto action_219
+action_103 (96#) = happyGoto action_220
+action_103 x = happyTcHack x happyReduce_303
+
+action_104 (173#) = happyShift action_237
+action_104 x = happyTcHack x happyFail
+
+action_105 (124#) = happyShift action_236
+action_105 x = happyTcHack x happyReduce_236
+
+action_106 x = happyTcHack x happyReduce_237
+
+action_107 (153#) = happyShift action_161
+action_107 x = happyTcHack x happyReduce_99
+
+action_108 x = happyTcHack x happyReduce_201
+
+action_109 x = happyTcHack x happyReduce_188
+
+action_110 (146#) = happyShift action_111
+action_110 (147#) = happyShift action_112
+action_110 (148#) = happyShift action_113
+action_110 (149#) = happyShift action_43
+action_110 (150#) = happyShift action_44
+action_110 (151#) = happyShift action_45
+action_110 (152#) = happyShift action_46
+action_110 (153#) = happyShift action_47
+action_110 (156#) = happyShift action_114
+action_110 (31#) = happyGoto action_107
+action_110 (32#) = happyGoto action_108
+action_110 (56#) = happyGoto action_235
+action_110 x = happyTcHack x happyFail
+
+action_111 x = happyTcHack x happyReduce_204
+
+action_112 x = happyTcHack x happyReduce_205
+
+action_113 x = happyTcHack x happyReduce_203
+
+action_114 x = happyTcHack x happyReduce_202
+
+action_115 x = happyTcHack x happyReduce_190
+
+action_116 (146#) = happyShift action_111
+action_116 (147#) = happyShift action_112
+action_116 (148#) = happyShift action_113
+action_116 (149#) = happyShift action_43
+action_116 (150#) = happyShift action_44
+action_116 (151#) = happyShift action_45
+action_116 (152#) = happyShift action_46
+action_116 (153#) = happyShift action_47
+action_116 (156#) = happyShift action_114
+action_116 (31#) = happyGoto action_107
+action_116 (32#) = happyGoto action_108
+action_116 (56#) = happyGoto action_234
+action_116 x = happyTcHack x happyFail
+
+action_117 x = happyTcHack x happyReduce_96
+
+action_118 (168#) = happyShift action_233
+action_118 (176#) = happyShift action_86
+action_118 (114#) = happyGoto action_232
+action_118 x = happyTcHack x happyFail
+
+action_119 (153#) = happyShift action_161
+action_119 (154#) = happyShift action_230
+action_119 (155#) = happyShift action_231
+action_119 x = happyTcHack x happyReduce_99
+
+action_120 x = happyTcHack x happyReduce_71
+
+action_121 x = happyTcHack x happyReduce_79
+
+action_122 x = happyTcHack x happyReduce_93
+
+action_123 (181#) = happyShift action_229
+action_123 x = happyTcHack x happyReduce_90
+
+action_124 x = happyTcHack x happyReduce_92
+
+action_125 x = happyTcHack x happyReduce_74
+
+action_126 (149#) = happyShift action_43
+action_126 (150#) = happyShift action_44
+action_126 (151#) = happyShift action_45
+action_126 (152#) = happyShift action_46
+action_126 (153#) = happyShift action_47
+action_126 (156#) = happyShift action_228
+action_126 (31#) = happyGoto action_107
+action_126 (32#) = happyGoto action_227
+action_126 x = happyTcHack x happyReduce_82
+
+action_127 (149#) = happyShift action_43
+action_127 (150#) = happyShift action_44
+action_127 (151#) = happyShift action_45
+action_127 (152#) = happyShift action_46
+action_127 (153#) = happyShift action_47
+action_127 (156#) = happyShift action_226
+action_127 (31#) = happyGoto action_107
+action_127 (32#) = happyGoto action_225
+action_127 x = happyTcHack x happyReduce_81
+
+action_128 (181#) = happyShift action_224
+action_128 x = happyTcHack x happyReduce_72
+
+action_129 (181#) = happyShift action_223
+action_129 x = happyTcHack x happyReduce_73
+
+action_130 (181#) = happyShift action_222
+action_130 x = happyTcHack x happyReduce_75
+
+action_131 x = happyTcHack x happyReduce_89
+
+action_132 x = happyTcHack x happyReduce_43
+
+action_133 x = happyTcHack x happyReduce_44
+
+action_134 x = happyTcHack x happyReduce_45
+
+action_135 (122#) = happyShift action_221
+action_135 x = happyTcHack x happyReduce_22
+
+action_136 x = happyTcHack x happyReduce_347
+
+action_137 (168#) = happyShift action_55
+action_137 (94#) = happyGoto action_218
+action_137 (95#) = happyGoto action_219
+action_137 (96#) = happyGoto action_220
+action_137 x = happyTcHack x happyReduce_303
+
+action_138 (193#) = happyShift action_69
+action_138 (109#) = happyGoto action_217
+action_138 (110#) = happyGoto action_34
+action_138 (111#) = happyGoto action_35
+action_138 x = happyTcHack x happyReduce_344
+
+action_139 (193#) = happyShift action_69
+action_139 (109#) = happyGoto action_216
+action_139 (110#) = happyGoto action_34
+action_139 (111#) = happyGoto action_35
+action_139 x = happyTcHack x happyReduce_344
+
+action_140 (120#) = happyShift action_148
+action_140 (124#) = happyShift action_104
+action_140 (146#) = happyShift action_105
+action_140 (172#) = happyShift action_106
+action_140 (176#) = happyShift action_86
+action_140 (181#) = happyShift action_150
+action_140 (66#) = happyGoto action_214
+action_140 (67#) = happyGoto action_142
+action_140 (68#) = happyGoto action_215
+action_140 (69#) = happyGoto action_144
+action_140 (70#) = happyGoto action_145
+action_140 (71#) = happyGoto action_146
+action_140 (114#) = happyGoto action_102
+action_140 x = happyTcHack x happyFail
+
+action_141 (120#) = happyShift action_212
+action_141 (168#) = happyShift action_213
+action_141 x = happyTcHack x happyReduce_225
+
+action_142 x = happyTcHack x happyReduce_228
+
+action_143 x = happyTcHack x happyReduce_223
+
+action_144 x = happyTcHack x happyReduce_231
+
+action_145 x = happyTcHack x happyReduce_230
+
+action_146 (120#) = happyShift action_148
+action_146 (124#) = happyShift action_104
+action_146 (146#) = happyShift action_105
+action_146 (172#) = happyShift action_106
+action_146 (175#) = happyShift action_211
+action_146 (176#) = happyShift action_86
+action_146 (193#) = happyShift action_69
+action_146 (66#) = happyGoto action_209
+action_146 (67#) = happyGoto action_142
+action_146 (69#) = happyGoto action_144
+action_146 (70#) = happyGoto action_145
+action_146 (110#) = happyGoto action_210
+action_146 (111#) = happyGoto action_35
+action_146 (114#) = happyGoto action_102
+action_146 x = happyTcHack x happyFail
+
+action_147 (193#) = happyShift action_69
+action_147 (111#) = happyGoto action_136
+action_147 x = happyTcHack x happyReduce_226
+
+action_148 (120#) = happyShift action_148
+action_148 (124#) = happyShift action_104
+action_148 (146#) = happyShift action_105
+action_148 (172#) = happyShift action_106
+action_148 (175#) = happyShift action_149
+action_148 (176#) = happyShift action_86
+action_148 (181#) = happyShift action_150
+action_148 (193#) = happyShift action_69
+action_148 (64#) = happyGoto action_208
+action_148 (65#) = happyGoto action_140
+action_148 (66#) = happyGoto action_141
+action_148 (67#) = happyGoto action_142
+action_148 (68#) = happyGoto action_143
+action_148 (69#) = happyGoto action_144
+action_148 (70#) = happyGoto action_145
+action_148 (71#) = happyGoto action_146
+action_148 (110#) = happyGoto action_147
+action_148 (111#) = happyGoto action_35
+action_148 (114#) = happyGoto action_102
+action_148 x = happyTcHack x happyFail
+
+action_149 x = happyTcHack x happyReduce_227
+
+action_150 (128#) = happyShift action_157
+action_150 (129#) = happyShift action_158
+action_150 (181#) = happyShift action_150
+action_150 (54#) = happyGoto action_205
+action_150 (71#) = happyGoto action_206
+action_150 (72#) = happyGoto action_207
+action_150 x = happyTcHack x happyReduce_247
+
+action_151 x = happyTcHack x happyReduce_19
+
+action_152 x = happyTcHack x happyReduce_166
+
+action_153 (1#) = happyShift action_122
+action_153 (146#) = happyShift action_123
+action_153 (147#) = happyShift action_124
+action_153 (148#) = happyShift action_125
+action_153 (149#) = happyShift action_43
+action_153 (150#) = happyShift action_44
+action_153 (151#) = happyShift action_45
+action_153 (152#) = happyShift action_46
+action_153 (153#) = happyShift action_47
+action_153 (154#) = happyShift action_126
+action_153 (155#) = happyShift action_127
+action_153 (156#) = happyShift action_128
+action_153 (157#) = happyShift action_129
+action_153 (171#) = happyShift action_130
+action_153 (176#) = happyShift action_131
+action_153 (183#) = happyShift action_61
+action_153 (184#) = happyShift action_62
+action_153 (30#) = happyGoto action_204
+action_153 (31#) = happyGoto action_119
+action_153 (32#) = happyGoto action_120
+action_153 (89#) = happyGoto action_121
+action_153 (90#) = happyGoto action_29
+action_153 x = happyTcHack x happyFail
+
+action_154 (146#) = happyShift action_90
+action_154 (176#) = happyShift action_86
+action_154 (114#) = happyGoto action_203
+action_154 x = happyTcHack x happyFail
+
+action_155 (120#) = happyShift action_195
+action_155 (141#) = happyShift action_196
+action_155 (142#) = happyShift action_197
+action_155 (170#) = happyShift action_198
+action_155 (173#) = happyShift action_199
+action_155 (174#) = happyShift action_200
+action_155 (176#) = happyShift action_86
+action_155 (180#) = happyShift action_201
+action_155 (182#) = happyShift action_202
+action_155 (44#) = happyGoto action_187
+action_155 (45#) = happyGoto action_188
+action_155 (46#) = happyGoto action_189
+action_155 (47#) = happyGoto action_190
+action_155 (48#) = happyGoto action_191
+action_155 (49#) = happyGoto action_192
+action_155 (50#) = happyGoto action_193
+action_155 (114#) = happyGoto action_194
+action_155 x = happyTcHack x happyFail
+
+action_156 x = happyTcHack x happyReduce_178
+
+action_157 x = happyTcHack x happyReduce_179
+
+action_158 x = happyTcHack x happyReduce_180
+
+action_159 (169#) = happyShift action_186
+action_159 x = happyTcHack x happyFail
+
+action_160 x = happyTcHack x happyReduce_11
+
+action_161 x = happyTcHack x happyReduce_100
+
+action_162 (153#) = happyShift action_185
+action_162 x = happyTcHack x happyFail
+
+action_163 (153#) = happyShift action_184
+action_163 x = happyTcHack x happyFail
+
+action_164 x = happyTcHack x happyReduce_17
+
+action_165 x = happyTcHack x happyReduce_15
+
+action_166 x = happyTcHack x happyReduce_356
+
+action_167 x = happyTcHack x happyReduce_357
+
+action_168 x = happyTcHack x happyReduce_14
+
+action_169 (119#) = happyShift action_182
+action_169 (186#) = happyShift action_183
+action_169 x = happyTcHack x happyFail
+
+action_170 (122#) = happyShift action_181
+action_170 x = happyTcHack x happyFail
+
+action_171 (146#) = happyShift action_180
+action_171 (176#) = happyShift action_86
+action_171 (114#) = happyGoto action_179
+action_171 x = happyTcHack x happyFail
+
+action_172 x = happyTcHack x happyReduce_13
+
+action_173 x = happyTcHack x happyReduce_6
+
+action_174 (124#) = happyShift action_177
+action_174 (130#) = happyShift action_178
+action_174 x = happyTcHack x happyFail
+
+action_175 x = happyTcHack x happyReduce_10
+
+action_176 x = happyTcHack x happyReduce_9
+
+action_177 (168#) = happyShift action_55
+action_177 (94#) = happyGoto action_391
+action_177 (95#) = happyGoto action_219
+action_177 (96#) = happyGoto action_220
+action_177 x = happyTcHack x happyReduce_303
+
+action_178 (168#) = happyShift action_55
+action_178 (94#) = happyGoto action_390
+action_178 (95#) = happyGoto action_219
+action_178 (96#) = happyGoto action_220
+action_178 x = happyTcHack x happyReduce_303
+
+action_179 x = happyTcHack x happyReduce_62
+
+action_180 x = happyTcHack x happyReduce_61
+
+action_181 (22#) = happyGoto action_389
+action_181 x = happyTcHack x happyReduce_51
+
+action_182 (124#) = happyShift action_104
+action_182 (146#) = happyShift action_105
+action_182 (172#) = happyShift action_106
+action_182 (176#) = happyShift action_86
+action_182 (67#) = happyGoto action_388
+action_182 (114#) = happyGoto action_102
+action_182 x = happyTcHack x happyFail
+
+action_183 (124#) = happyShift action_387
+action_183 x = happyTcHack x happyFail
+
+action_184 x = happyTcHack x happyReduce_192
+
+action_185 x = happyTcHack x happyReduce_193
+
+action_186 x = happyTcHack x happyReduce_177
+
+action_187 (138#) = happyShift action_276
+action_187 (166#) = happyShift action_386
+action_187 x = happyTcHack x happyFail
+
+action_188 (180#) = happyShift action_384
+action_188 (182#) = happyShift action_385
+action_188 x = happyTcHack x happyReduce_143
+
+action_189 (139#) = happyShift action_381
+action_189 (140#) = happyShift action_382
+action_189 (181#) = happyShift action_383
+action_189 x = happyTcHack x happyReduce_145
+
+action_190 x = happyTcHack x happyReduce_148
+
+action_191 x = happyTcHack x happyReduce_152
+
+action_192 (120#) = happyShift action_380
+action_192 (173#) = happyShift action_199
+action_192 (174#) = happyShift action_200
+action_192 (176#) = happyShift action_86
+action_192 (50#) = happyGoto action_379
+action_192 (114#) = happyGoto action_194
+action_192 x = happyTcHack x happyFail
+
+action_193 x = happyTcHack x happyReduce_154
+
+action_194 x = happyTcHack x happyReduce_161
+
+action_195 (1#) = happyShift action_369
+action_195 (120#) = happyShift action_195
+action_195 (141#) = happyShift action_196
+action_195 (142#) = happyShift action_197
+action_195 (146#) = happyShift action_370
+action_195 (147#) = happyShift action_371
+action_195 (148#) = happyShift action_372
+action_195 (149#) = happyShift action_43
+action_195 (150#) = happyShift action_44
+action_195 (151#) = happyShift action_45
+action_195 (152#) = happyShift action_46
+action_195 (153#) = happyShift action_47
+action_195 (154#) = happyShift action_373
+action_195 (155#) = happyShift action_374
+action_195 (156#) = happyShift action_375
+action_195 (157#) = happyShift action_376
+action_195 (170#) = happyShift action_198
+action_195 (171#) = happyShift action_377
+action_195 (173#) = happyShift action_199
+action_195 (174#) = happyShift action_200
+action_195 (176#) = happyShift action_378
+action_195 (180#) = happyShift action_201
+action_195 (182#) = happyShift action_202
+action_195 (183#) = happyShift action_61
+action_195 (184#) = happyShift action_62
+action_195 (30#) = happyGoto action_363
+action_195 (31#) = happyGoto action_364
+action_195 (32#) = happyGoto action_365
+action_195 (33#) = happyGoto action_366
+action_195 (34#) = happyGoto action_367
+action_195 (35#) = happyGoto action_265
+action_195 (36#) = happyGoto action_266
+action_195 (37#) = happyGoto action_267
+action_195 (38#) = happyGoto action_268
+action_195 (39#) = happyGoto action_269
+action_195 (40#) = happyGoto action_270
+action_195 (41#) = happyGoto action_271
+action_195 (43#) = happyGoto action_272
+action_195 (44#) = happyGoto action_273
+action_195 (45#) = happyGoto action_188
+action_195 (46#) = happyGoto action_189
+action_195 (47#) = happyGoto action_190
+action_195 (48#) = happyGoto action_191
+action_195 (49#) = happyGoto action_192
+action_195 (50#) = happyGoto action_193
+action_195 (89#) = happyGoto action_368
+action_195 (90#) = happyGoto action_29
+action_195 (114#) = happyGoto action_194
+action_195 x = happyTcHack x happyFail
+
+action_196 x = happyTcHack x happyReduce_159
+
+action_197 x = happyTcHack x happyReduce_160
+
+action_198 (120#) = happyShift action_362
+action_198 x = happyTcHack x happyFail
+
+action_199 x = happyTcHack x happyReduce_162
+
+action_200 x = happyTcHack x happyReduce_163
+
+action_201 x = happyTcHack x happyReduce_158
+
+action_202 x = happyTcHack x happyReduce_157
+
+action_203 x = happyTcHack x happyReduce_46
+
+action_204 (168#) = happyShift action_233
+action_204 (176#) = happyShift action_86
+action_204 (114#) = happyGoto action_361
+action_204 x = happyTcHack x happyFail
+
+action_205 x = happyTcHack x happyReduce_251
+
+action_206 x = happyTcHack x happyReduce_249
+
+action_207 (128#) = happyShift action_157
+action_207 (129#) = happyShift action_158
+action_207 (181#) = happyShift action_150
+action_207 (54#) = happyGoto action_359
+action_207 (71#) = happyGoto action_360
+action_207 x = happyTcHack x happyReduce_248
+
+action_208 (121#) = happyShift action_358
+action_208 x = happyTcHack x happyFail
+
+action_209 (120#) = happyShift action_212
+action_209 (168#) = happyShift action_213
+action_209 x = happyTcHack x happyReduce_238
+
+action_210 (120#) = happyShift action_148
+action_210 (124#) = happyShift action_104
+action_210 (146#) = happyShift action_105
+action_210 (172#) = happyShift action_106
+action_210 (176#) = happyShift action_86
+action_210 (193#) = happyShift action_69
+action_210 (66#) = happyGoto action_357
+action_210 (67#) = happyGoto action_142
+action_210 (69#) = happyGoto action_144
+action_210 (70#) = happyGoto action_145
+action_210 (111#) = happyGoto action_136
+action_210 (114#) = happyGoto action_102
+action_210 x = happyTcHack x happyFail
+
+action_211 (120#) = happyShift action_148
+action_211 (124#) = happyShift action_104
+action_211 (146#) = happyShift action_105
+action_211 (172#) = happyShift action_106
+action_211 (176#) = happyShift action_86
+action_211 (66#) = happyGoto action_356
+action_211 (67#) = happyGoto action_142
+action_211 (69#) = happyGoto action_144
+action_211 (70#) = happyGoto action_145
+action_211 (114#) = happyGoto action_102
+action_211 x = happyTcHack x happyFail
+
+action_212 (121#) = happyShift action_354
+action_212 (127#) = happyShift action_355
+action_212 (168#) = happyShift action_55
+action_212 (94#) = happyGoto action_351
+action_212 (95#) = happyGoto action_219
+action_212 (96#) = happyGoto action_220
+action_212 (105#) = happyGoto action_352
+action_212 (106#) = happyGoto action_353
+action_212 x = happyTcHack x happyReduce_303
+
+action_213 (120#) = happyShift action_195
+action_213 (141#) = happyShift action_196
+action_213 (142#) = happyShift action_197
+action_213 (169#) = happyShift action_349
+action_213 (170#) = happyShift action_198
+action_213 (173#) = happyShift action_199
+action_213 (174#) = happyShift action_200
+action_213 (176#) = happyShift action_86
+action_213 (180#) = happyShift action_201
+action_213 (181#) = happyShift action_350
+action_213 (182#) = happyShift action_202
+action_213 (34#) = happyGoto action_347
+action_213 (35#) = happyGoto action_265
+action_213 (36#) = happyGoto action_266
+action_213 (37#) = happyGoto action_267
+action_213 (38#) = happyGoto action_268
+action_213 (39#) = happyGoto action_269
+action_213 (40#) = happyGoto action_270
+action_213 (41#) = happyGoto action_271
+action_213 (43#) = happyGoto action_272
+action_213 (44#) = happyGoto action_273
+action_213 (45#) = happyGoto action_188
+action_213 (46#) = happyGoto action_189
+action_213 (47#) = happyGoto action_190
+action_213 (48#) = happyGoto action_191
+action_213 (49#) = happyGoto action_192
+action_213 (50#) = happyGoto action_348
+action_213 (114#) = happyGoto action_194
+action_213 x = happyTcHack x happyFail
+
+action_214 (120#) = happyShift action_212
+action_214 (168#) = happyShift action_213
+action_214 x = happyTcHack x happyReduce_224
+
+action_215 x = happyTcHack x happyReduce_222
+
+action_216 x = happyTcHack x happyReduce_301
+
+action_217 (1#) = happyShift action_36
+action_217 (128#) = happyShift action_157
+action_217 (129#) = happyShift action_158
+action_217 (146#) = happyShift action_40
+action_217 (147#) = happyShift action_41
+action_217 (148#) = happyShift action_42
+action_217 (149#) = happyShift action_43
+action_217 (150#) = happyShift action_44
+action_217 (151#) = happyShift action_45
+action_217 (152#) = happyShift action_46
+action_217 (153#) = happyShift action_47
+action_217 (154#) = happyShift action_48
+action_217 (155#) = happyShift action_49
+action_217 (156#) = happyShift action_50
+action_217 (157#) = happyShift action_51
+action_217 (158#) = happyShift action_52
+action_217 (159#) = happyShift action_53
+action_217 (163#) = happyShift action_54
+action_217 (171#) = happyShift action_56
+action_217 (176#) = happyShift action_57
+action_217 (197#) = happyShift action_73
+action_217 (31#) = happyGoto action_18
+action_217 (32#) = happyGoto action_19
+action_217 (52#) = happyGoto action_346
+action_217 (54#) = happyGoto action_333
+action_217 (55#) = happyGoto action_334
+action_217 (59#) = happyGoto action_76
+action_217 (60#) = happyGoto action_25
+action_217 (61#) = happyGoto action_26
+action_217 (86#) = happyGoto action_77
+action_217 x = happyTcHack x happyFail
+
+action_218 (1#) = happyShift action_36
+action_218 (128#) = happyShift action_157
+action_218 (129#) = happyShift action_158
+action_218 (146#) = happyShift action_40
+action_218 (147#) = happyShift action_41
+action_218 (148#) = happyShift action_42
+action_218 (149#) = happyShift action_43
+action_218 (150#) = happyShift action_44
+action_218 (151#) = happyShift action_45
+action_218 (152#) = happyShift action_46
+action_218 (153#) = happyShift action_47
+action_218 (154#) = happyShift action_48
+action_218 (155#) = happyShift action_49
+action_218 (156#) = happyShift action_50
+action_218 (157#) = happyShift action_51
+action_218 (158#) = happyShift action_52
+action_218 (159#) = happyShift action_53
+action_218 (163#) = happyShift action_54
+action_218 (171#) = happyShift action_56
+action_218 (176#) = happyShift action_57
+action_218 (197#) = happyShift action_73
+action_218 (31#) = happyGoto action_18
+action_218 (32#) = happyGoto action_19
+action_218 (52#) = happyGoto action_345
+action_218 (54#) = happyGoto action_333
+action_218 (55#) = happyGoto action_334
+action_218 (59#) = happyGoto action_76
+action_218 (60#) = happyGoto action_25
+action_218 (61#) = happyGoto action_26
+action_218 (86#) = happyGoto action_77
+action_218 x = happyTcHack x happyFail
+
+action_219 x = happyTcHack x happyReduce_302
+
+action_220 (168#) = happyShift action_55
+action_220 (95#) = happyGoto action_344
+action_220 (96#) = happyGoto action_220
+action_220 x = happyTcHack x happyReduce_303
+
+action_221 (5#) = happyGoto action_343
+action_221 x = happyTcHack x happyReduce_3
+
+action_222 x = happyTcHack x happyReduce_76
+
+action_223 x = happyTcHack x happyReduce_78
+
+action_224 x = happyTcHack x happyReduce_77
+
+action_225 x = happyTcHack x happyReduce_84
+
+action_226 x = happyTcHack x happyReduce_88
+
+action_227 x = happyTcHack x happyReduce_83
+
+action_228 x = happyTcHack x happyReduce_85
+
+action_229 x = happyTcHack x happyReduce_91
+
+action_230 (153#) = happyShift action_342
+action_230 x = happyTcHack x happyFail
+
+action_231 (153#) = happyShift action_341
+action_231 x = happyTcHack x happyFail
+
+action_232 (130#) = happyShift action_340
+action_232 x = happyTcHack x happyFail
+
+action_233 (169#) = happyShift action_339
+action_233 x = happyTcHack x happyFail
+
+action_234 x = happyTcHack x happyReduce_191
+
+action_235 x = happyTcHack x happyReduce_189
+
+action_236 (173#) = happyShift action_338
+action_236 x = happyTcHack x happyFail
+
+action_237 x = happyTcHack x happyReduce_235
+
+action_238 (123#) = happyShift action_337
+action_238 (168#) = happyShift action_55
+action_238 (74#) = happyGoto action_336
+action_238 (94#) = happyGoto action_240
+action_238 (95#) = happyGoto action_219
+action_238 (96#) = happyGoto action_220
+action_238 x = happyTcHack x happyReduce_303
+
+action_239 (193#) = happyShift action_69
+action_239 (109#) = happyGoto action_335
+action_239 (110#) = happyGoto action_34
+action_239 (111#) = happyGoto action_35
+action_239 x = happyTcHack x happyReduce_344
+
+action_240 (1#) = happyShift action_36
+action_240 (128#) = happyShift action_157
+action_240 (129#) = happyShift action_158
+action_240 (146#) = happyShift action_40
+action_240 (147#) = happyShift action_41
+action_240 (148#) = happyShift action_42
+action_240 (149#) = happyShift action_43
+action_240 (150#) = happyShift action_44
+action_240 (151#) = happyShift action_45
+action_240 (152#) = happyShift action_46
+action_240 (153#) = happyShift action_47
+action_240 (154#) = happyShift action_48
+action_240 (155#) = happyShift action_49
+action_240 (156#) = happyShift action_50
+action_240 (157#) = happyShift action_51
+action_240 (158#) = happyShift action_52
+action_240 (159#) = happyShift action_53
+action_240 (163#) = happyShift action_54
+action_240 (171#) = happyShift action_56
+action_240 (176#) = happyShift action_57
+action_240 (197#) = happyShift action_73
+action_240 (31#) = happyGoto action_18
+action_240 (32#) = happyGoto action_19
+action_240 (52#) = happyGoto action_332
+action_240 (54#) = happyGoto action_333
+action_240 (55#) = happyGoto action_334
+action_240 (59#) = happyGoto action_76
+action_240 (60#) = happyGoto action_25
+action_240 (61#) = happyGoto action_26
+action_240 (86#) = happyGoto action_77
+action_240 x = happyTcHack x happyFail
+
+action_241 (173#) = happyShift action_331
+action_241 x = happyTcHack x happyFail
+
+action_242 (168#) = happyShift action_55
+action_242 (73#) = happyGoto action_330
+action_242 (74#) = happyGoto action_239
+action_242 (94#) = happyGoto action_240
+action_242 (95#) = happyGoto action_219
+action_242 (96#) = happyGoto action_220
+action_242 x = happyTcHack x happyReduce_303
+
+action_243 x = happyTcHack x happyReduce_217
+
+action_244 (161#) = happyShift action_327
+action_244 (162#) = happyShift action_328
+action_244 (168#) = happyShift action_329
+action_244 (62#) = happyGoto action_321
+action_244 (73#) = happyGoto action_322
+action_244 (74#) = happyGoto action_239
+action_244 (77#) = happyGoto action_323
+action_244 (78#) = happyGoto action_324
+action_244 (81#) = happyGoto action_325
+action_244 (82#) = happyGoto action_326
+action_244 (94#) = happyGoto action_240
+action_244 (95#) = happyGoto action_219
+action_244 (96#) = happyGoto action_220
+action_244 x = happyTcHack x happyReduce_303
+
+action_245 (120#) = happyShift action_320
+action_245 x = happyTcHack x happyFail
+
+action_246 (125#) = happyShift action_319
+action_246 (116#) = happyGoto action_318
+action_246 x = happyTcHack x happyReduce_358
+
+action_247 x = happyTcHack x happyReduce_288
+
+action_248 (176#) = happyShift action_86
+action_248 (114#) = happyGoto action_317
+action_248 x = happyTcHack x happyFail
+
+action_249 (130#) = happyShift action_316
+action_249 x = happyTcHack x happyReduce_290
+
+action_250 (168#) = happyShift action_55
+action_250 (176#) = happyShift action_86
+action_250 (87#) = happyGoto action_315
+action_250 (88#) = happyGoto action_247
+action_250 (96#) = happyGoto action_248
+action_250 (114#) = happyGoto action_249
+action_250 x = happyTcHack x happyFail
+
+action_251 x = happyTcHack x happyReduce_309
+
+action_252 (120#) = happyShift action_195
+action_252 (122#) = happyShift action_310
+action_252 (141#) = happyShift action_196
+action_252 (142#) = happyShift action_197
+action_252 (146#) = happyShift action_311
+action_252 (154#) = happyShift action_312
+action_252 (155#) = happyShift action_313
+action_252 (170#) = happyShift action_198
+action_252 (173#) = happyShift action_199
+action_252 (174#) = happyShift action_200
+action_252 (176#) = happyShift action_86
+action_252 (180#) = happyShift action_201
+action_252 (181#) = happyShift action_314
+action_252 (182#) = happyShift action_202
+action_252 (34#) = happyGoto action_307
+action_252 (35#) = happyGoto action_265
+action_252 (36#) = happyGoto action_266
+action_252 (37#) = happyGoto action_267
+action_252 (38#) = happyGoto action_268
+action_252 (39#) = happyGoto action_269
+action_252 (40#) = happyGoto action_270
+action_252 (41#) = happyGoto action_271
+action_252 (43#) = happyGoto action_272
+action_252 (44#) = happyGoto action_273
+action_252 (45#) = happyGoto action_188
+action_252 (46#) = happyGoto action_189
+action_252 (47#) = happyGoto action_190
+action_252 (48#) = happyGoto action_191
+action_252 (49#) = happyGoto action_192
+action_252 (50#) = happyGoto action_193
+action_252 (102#) = happyGoto action_308
+action_252 (103#) = happyGoto action_309
+action_252 (114#) = happyGoto action_194
+action_252 x = happyTcHack x happyReduce_321
+
+action_253 (169#) = happyShift action_306
+action_253 x = happyTcHack x happyFail
+
+action_254 (172#) = happyShift action_95
+action_254 (176#) = happyShift action_86
+action_254 (183#) = happyShift action_96
+action_254 (98#) = happyGoto action_305
+action_254 (114#) = happyGoto action_93
+action_254 x = happyTcHack x happyReduce_359
+
+action_255 x = happyTcHack x happyReduce_12
+
+action_256 (168#) = happyShift action_303
+action_256 (14#) = happyGoto action_304
+action_256 (15#) = happyGoto action_301
+action_256 (16#) = happyGoto action_302
+action_256 x = happyTcHack x happyReduce_39
+
+action_257 (168#) = happyShift action_303
+action_257 (14#) = happyGoto action_300
+action_257 (15#) = happyGoto action_301
+action_257 (16#) = happyGoto action_302
+action_257 x = happyTcHack x happyReduce_39
+
+action_258 (5#) = happyGoto action_299
+action_258 x = happyTcHack x happyReduce_3
+
+action_259 (121#) = happyShift action_298
+action_259 x = happyTcHack x happyFail
+
+action_260 (121#) = happyShift action_297
+action_260 x = happyTcHack x happyFail
+
+action_261 (121#) = happyShift action_296
+action_261 x = happyTcHack x happyFail
+
+action_262 (146#) = happyShift action_293
+action_262 (175#) = happyShift action_294
+action_262 (176#) = happyShift action_295
+action_262 (112#) = happyGoto action_291
+action_262 (113#) = happyGoto action_292
+action_262 x = happyTcHack x happyFail
+
+action_263 (174#) = happyShift action_80
+action_263 (29#) = happyGoto action_290
+action_263 x = happyTcHack x happyFail
+
+action_264 x = happyTcHack x happyReduce_68
+
+action_265 (143#) = happyShift action_289
+action_265 x = happyTcHack x happyReduce_121
+
+action_266 (134#) = happyShift action_288
+action_266 x = happyTcHack x happyReduce_122
+
+action_267 (137#) = happyShift action_287
+action_267 x = happyTcHack x happyReduce_124
+
+action_268 (133#) = happyShift action_286
+action_268 x = happyTcHack x happyReduce_126
+
+action_269 (135#) = happyShift action_285
+action_269 x = happyTcHack x happyReduce_128
+
+action_270 (136#) = happyShift action_284
+action_270 x = happyTcHack x happyReduce_130
+
+action_271 (131#) = happyShift action_282
+action_271 (132#) = happyShift action_283
+action_271 (42#) = happyGoto action_281
+action_271 x = happyTcHack x happyReduce_132
+
+action_272 (164#) = happyShift action_277
+action_272 (165#) = happyShift action_278
+action_272 (166#) = happyShift action_279
+action_272 (167#) = happyShift action_280
+action_272 x = happyTcHack x happyReduce_134
+
+action_273 (138#) = happyShift action_276
+action_273 x = happyTcHack x happyReduce_138
+
+action_274 x = happyTcHack x happyReduce_197
+
+action_275 x = happyTcHack x happyReduce_207
+
+action_276 (120#) = happyShift action_195
+action_276 (141#) = happyShift action_196
+action_276 (142#) = happyShift action_197
+action_276 (170#) = happyShift action_198
+action_276 (173#) = happyShift action_199
+action_276 (174#) = happyShift action_200
+action_276 (176#) = happyShift action_86
+action_276 (180#) = happyShift action_201
+action_276 (182#) = happyShift action_202
+action_276 (45#) = happyGoto action_492
+action_276 (46#) = happyGoto action_189
+action_276 (47#) = happyGoto action_190
+action_276 (48#) = happyGoto action_191
+action_276 (49#) = happyGoto action_192
+action_276 (50#) = happyGoto action_193
+action_276 (114#) = happyGoto action_194
+action_276 x = happyTcHack x happyFail
+
+action_277 (120#) = happyShift action_195
+action_277 (141#) = happyShift action_196
+action_277 (142#) = happyShift action_197
+action_277 (170#) = happyShift action_198
+action_277 (173#) = happyShift action_199
+action_277 (174#) = happyShift action_200
+action_277 (176#) = happyShift action_86
+action_277 (180#) = happyShift action_201
+action_277 (182#) = happyShift action_202
+action_277 (44#) = happyGoto action_491
+action_277 (45#) = happyGoto action_188
+action_277 (46#) = happyGoto action_189
+action_277 (47#) = happyGoto action_190
+action_277 (48#) = happyGoto action_191
+action_277 (49#) = happyGoto action_192
+action_277 (50#) = happyGoto action_193
+action_277 (114#) = happyGoto action_194
+action_277 x = happyTcHack x happyFail
+
+action_278 (120#) = happyShift action_195
+action_278 (141#) = happyShift action_196
+action_278 (142#) = happyShift action_197
+action_278 (170#) = happyShift action_198
+action_278 (173#) = happyShift action_199
+action_278 (174#) = happyShift action_200
+action_278 (176#) = happyShift action_86
+action_278 (180#) = happyShift action_201
+action_278 (182#) = happyShift action_202
+action_278 (44#) = happyGoto action_490
+action_278 (45#) = happyGoto action_188
+action_278 (46#) = happyGoto action_189
+action_278 (47#) = happyGoto action_190
+action_278 (48#) = happyGoto action_191
+action_278 (49#) = happyGoto action_192
+action_278 (50#) = happyGoto action_193
+action_278 (114#) = happyGoto action_194
+action_278 x = happyTcHack x happyFail
+
+action_279 (120#) = happyShift action_195
+action_279 (141#) = happyShift action_196
+action_279 (142#) = happyShift action_197
+action_279 (170#) = happyShift action_198
+action_279 (173#) = happyShift action_199
+action_279 (174#) = happyShift action_200
+action_279 (176#) = happyShift action_86
+action_279 (180#) = happyShift action_201
+action_279 (182#) = happyShift action_202
+action_279 (44#) = happyGoto action_489
+action_279 (45#) = happyGoto action_188
+action_279 (46#) = happyGoto action_189
+action_279 (47#) = happyGoto action_190
+action_279 (48#) = happyGoto action_191
+action_279 (49#) = happyGoto action_192
+action_279 (50#) = happyGoto action_193
+action_279 (114#) = happyGoto action_194
+action_279 x = happyTcHack x happyFail
+
+action_280 (120#) = happyShift action_195
+action_280 (141#) = happyShift action_196
+action_280 (142#) = happyShift action_197
+action_280 (170#) = happyShift action_198
+action_280 (173#) = happyShift action_199
+action_280 (174#) = happyShift action_200
+action_280 (176#) = happyShift action_86
+action_280 (180#) = happyShift action_201
+action_280 (182#) = happyShift action_202
+action_280 (44#) = happyGoto action_488
+action_280 (45#) = happyGoto action_188
+action_280 (46#) = happyGoto action_189
+action_280 (47#) = happyGoto action_190
+action_280 (48#) = happyGoto action_191
+action_280 (49#) = happyGoto action_192
+action_280 (50#) = happyGoto action_193
+action_280 (114#) = happyGoto action_194
+action_280 x = happyTcHack x happyFail
+
+action_281 (120#) = happyShift action_195
+action_281 (141#) = happyShift action_196
+action_281 (142#) = happyShift action_197
+action_281 (170#) = happyShift action_198
+action_281 (173#) = happyShift action_199
+action_281 (174#) = happyShift action_200
+action_281 (176#) = happyShift action_86
+action_281 (180#) = happyShift action_201
+action_281 (182#) = happyShift action_202
+action_281 (43#) = happyGoto action_487
+action_281 (44#) = happyGoto action_273
+action_281 (45#) = happyGoto action_188
+action_281 (46#) = happyGoto action_189
+action_281 (47#) = happyGoto action_190
+action_281 (48#) = happyGoto action_191
+action_281 (49#) = happyGoto action_192
+action_281 (50#) = happyGoto action_193
+action_281 (114#) = happyGoto action_194
+action_281 x = happyTcHack x happyFail
+
+action_282 x = happyTcHack x happyReduce_136
+
+action_283 x = happyTcHack x happyReduce_137
+
+action_284 (120#) = happyShift action_195
+action_284 (141#) = happyShift action_196
+action_284 (142#) = happyShift action_197
+action_284 (170#) = happyShift action_198
+action_284 (173#) = happyShift action_199
+action_284 (174#) = happyShift action_200
+action_284 (176#) = happyShift action_86
+action_284 (180#) = happyShift action_201
+action_284 (182#) = happyShift action_202
+action_284 (41#) = happyGoto action_486
+action_284 (43#) = happyGoto action_272
+action_284 (44#) = happyGoto action_273
+action_284 (45#) = happyGoto action_188
+action_284 (46#) = happyGoto action_189
+action_284 (47#) = happyGoto action_190
+action_284 (48#) = happyGoto action_191
+action_284 (49#) = happyGoto action_192
+action_284 (50#) = happyGoto action_193
+action_284 (114#) = happyGoto action_194
+action_284 x = happyTcHack x happyFail
+
+action_285 (120#) = happyShift action_195
+action_285 (141#) = happyShift action_196
+action_285 (142#) = happyShift action_197
+action_285 (170#) = happyShift action_198
+action_285 (173#) = happyShift action_199
+action_285 (174#) = happyShift action_200
+action_285 (176#) = happyShift action_86
+action_285 (180#) = happyShift action_201
+action_285 (182#) = happyShift action_202
+action_285 (40#) = happyGoto action_485
+action_285 (41#) = happyGoto action_271
+action_285 (43#) = happyGoto action_272
+action_285 (44#) = happyGoto action_273
+action_285 (45#) = happyGoto action_188
+action_285 (46#) = happyGoto action_189
+action_285 (47#) = happyGoto action_190
+action_285 (48#) = happyGoto action_191
+action_285 (49#) = happyGoto action_192
+action_285 (50#) = happyGoto action_193
+action_285 (114#) = happyGoto action_194
+action_285 x = happyTcHack x happyFail
+
+action_286 (120#) = happyShift action_195
+action_286 (141#) = happyShift action_196
+action_286 (142#) = happyShift action_197
+action_286 (170#) = happyShift action_198
+action_286 (173#) = happyShift action_199
+action_286 (174#) = happyShift action_200
+action_286 (176#) = happyShift action_86
+action_286 (180#) = happyShift action_201
+action_286 (182#) = happyShift action_202
+action_286 (39#) = happyGoto action_484
+action_286 (40#) = happyGoto action_270
+action_286 (41#) = happyGoto action_271
+action_286 (43#) = happyGoto action_272
+action_286 (44#) = happyGoto action_273
+action_286 (45#) = happyGoto action_188
+action_286 (46#) = happyGoto action_189
+action_286 (47#) = happyGoto action_190
+action_286 (48#) = happyGoto action_191
+action_286 (49#) = happyGoto action_192
+action_286 (50#) = happyGoto action_193
+action_286 (114#) = happyGoto action_194
+action_286 x = happyTcHack x happyFail
+
+action_287 (120#) = happyShift action_195
+action_287 (141#) = happyShift action_196
+action_287 (142#) = happyShift action_197
+action_287 (170#) = happyShift action_198
+action_287 (173#) = happyShift action_199
+action_287 (174#) = happyShift action_200
+action_287 (176#) = happyShift action_86
+action_287 (180#) = happyShift action_201
+action_287 (182#) = happyShift action_202
+action_287 (38#) = happyGoto action_483
+action_287 (39#) = happyGoto action_269
+action_287 (40#) = happyGoto action_270
+action_287 (41#) = happyGoto action_271
+action_287 (43#) = happyGoto action_272
+action_287 (44#) = happyGoto action_273
+action_287 (45#) = happyGoto action_188
+action_287 (46#) = happyGoto action_189
+action_287 (47#) = happyGoto action_190
+action_287 (48#) = happyGoto action_191
+action_287 (49#) = happyGoto action_192
+action_287 (50#) = happyGoto action_193
+action_287 (114#) = happyGoto action_194
+action_287 x = happyTcHack x happyFail
+
+action_288 (120#) = happyShift action_195
+action_288 (141#) = happyShift action_196
+action_288 (142#) = happyShift action_197
+action_288 (170#) = happyShift action_198
+action_288 (173#) = happyShift action_199
+action_288 (174#) = happyShift action_200
+action_288 (176#) = happyShift action_86
+action_288 (180#) = happyShift action_201
+action_288 (182#) = happyShift action_202
+action_288 (37#) = happyGoto action_482
+action_288 (38#) = happyGoto action_268
+action_288 (39#) = happyGoto action_269
+action_288 (40#) = happyGoto action_270
+action_288 (41#) = happyGoto action_271
+action_288 (43#) = happyGoto action_272
+action_288 (44#) = happyGoto action_273
+action_288 (45#) = happyGoto action_188
+action_288 (46#) = happyGoto action_189
+action_288 (47#) = happyGoto action_190
+action_288 (48#) = happyGoto action_191
+action_288 (49#) = happyGoto action_192
+action_288 (50#) = happyGoto action_193
+action_288 (114#) = happyGoto action_194
+action_288 x = happyTcHack x happyFail
+
+action_289 (120#) = happyShift action_195
+action_289 (141#) = happyShift action_196
+action_289 (142#) = happyShift action_197
+action_289 (170#) = happyShift action_198
+action_289 (173#) = happyShift action_199
+action_289 (174#) = happyShift action_200
+action_289 (176#) = happyShift action_86
+action_289 (180#) = happyShift action_201
+action_289 (182#) = happyShift action_202
+action_289 (34#) = happyGoto action_481
+action_289 (35#) = happyGoto action_265
+action_289 (36#) = happyGoto action_266
+action_289 (37#) = happyGoto action_267
+action_289 (38#) = happyGoto action_268
+action_289 (39#) = happyGoto action_269
+action_289 (40#) = happyGoto action_270
+action_289 (41#) = happyGoto action_271
+action_289 (43#) = happyGoto action_272
+action_289 (44#) = happyGoto action_273
+action_289 (45#) = happyGoto action_188
+action_289 (46#) = happyGoto action_189
+action_289 (47#) = happyGoto action_190
+action_289 (48#) = happyGoto action_191
+action_289 (49#) = happyGoto action_192
+action_289 (50#) = happyGoto action_193
+action_289 (114#) = happyGoto action_194
+action_289 x = happyTcHack x happyFail
+
+action_290 x = happyTcHack x happyReduce_70
+
+action_291 (121#) = happyShift action_480
+action_291 x = happyTcHack x happyFail
+
+action_292 (120#) = happyShift action_479
+action_292 x = happyTcHack x happyReduce_349
+
+action_293 x = happyTcHack x happyReduce_354
+
+action_294 x = happyTcHack x happyReduce_350
+
+action_295 x = happyTcHack x happyReduce_353
+
+action_296 x = happyTcHack x happyReduce_64
+
+action_297 x = happyTcHack x happyReduce_49
+
+action_298 x = happyTcHack x happyReduce_48
+
+action_299 (1#) = happyShift action_36
+action_299 (118#) = happyShift action_37
+action_299 (119#) = happyShift action_38
+action_299 (123#) = happyShift action_478
+action_299 (128#) = happyShift action_39
+action_299 (144#) = happyReduce_344
+action_299 (145#) = happyReduce_344
+action_299 (146#) = happyShift action_40
+action_299 (147#) = happyShift action_41
+action_299 (148#) = happyShift action_42
+action_299 (149#) = happyShift action_43
+action_299 (150#) = happyShift action_44
+action_299 (151#) = happyShift action_45
+action_299 (152#) = happyShift action_46
+action_299 (153#) = happyShift action_47
+action_299 (154#) = happyShift action_48
+action_299 (155#) = happyShift action_49
+action_299 (156#) = happyShift action_50
+action_299 (157#) = happyShift action_51
+action_299 (158#) = happyShift action_52
+action_299 (159#) = happyShift action_53
+action_299 (163#) = happyShift action_54
+action_299 (168#) = happyShift action_55
+action_299 (171#) = happyShift action_56
+action_299 (176#) = happyShift action_57
+action_299 (177#) = happyShift action_58
+action_299 (178#) = happyShift action_59
+action_299 (179#) = happyShift action_60
+action_299 (183#) = happyShift action_61
+action_299 (184#) = happyShift action_62
+action_299 (187#) = happyShift action_63
+action_299 (188#) = happyShift action_64
+action_299 (189#) = happyShift action_65
+action_299 (190#) = happyShift action_66
+action_299 (191#) = happyShift action_67
+action_299 (192#) = happyShift action_68
+action_299 (193#) = happyShift action_69
+action_299 (194#) = happyShift action_70
+action_299 (195#) = happyShift action_71
+action_299 (196#) = happyShift action_72
+action_299 (197#) = happyShift action_73
+action_299 (9#) = happyGoto action_6
+action_299 (10#) = happyGoto action_7
+action_299 (11#) = happyGoto action_8
+action_299 (12#) = happyGoto action_9
+action_299 (17#) = happyGoto action_10
+action_299 (18#) = happyGoto action_11
+action_299 (19#) = happyGoto action_12
+action_299 (20#) = happyGoto action_13
+action_299 (21#) = happyGoto action_14
+action_299 (26#) = happyGoto action_15
+action_299 (27#) = happyGoto action_16
+action_299 (28#) = happyGoto action_17
+action_299 (31#) = happyGoto action_18
+action_299 (32#) = happyGoto action_19
+action_299 (51#) = happyGoto action_20
+action_299 (53#) = happyGoto action_21
+action_299 (55#) = happyGoto action_22
+action_299 (58#) = happyGoto action_23
+action_299 (59#) = happyGoto action_24
+action_299 (60#) = happyGoto action_25
+action_299 (61#) = happyGoto action_26
+action_299 (86#) = happyGoto action_27
+action_299 (89#) = happyGoto action_28
+action_299 (90#) = happyGoto action_29
+action_299 (93#) = happyGoto action_30
+action_299 (96#) = happyGoto action_31
+action_299 (104#) = happyGoto action_32
+action_299 (109#) = happyGoto action_33
+action_299 (110#) = happyGoto action_34
+action_299 (111#) = happyGoto action_35
+action_299 x = happyTcHack x happyFail
+
+action_300 (117#) = happyShift action_477
+action_300 x = happyTcHack x happyFail
+
+action_301 x = happyTcHack x happyReduce_33
+
+action_302 (119#) = happyShift action_475
+action_302 (177#) = happyShift action_476
+action_302 x = happyTcHack x happyFail
+
+action_303 (162#) = happyShift action_474
+action_303 (176#) = happyShift action_86
+action_303 (99#) = happyGoto action_471
+action_303 (100#) = happyGoto action_472
+action_303 (114#) = happyGoto action_473
+action_303 x = happyTcHack x happyFail
+
+action_304 (117#) = happyShift action_470
+action_304 x = happyTcHack x happyFail
+
+action_305 x = happyTcHack x happyReduce_308
+
+action_306 x = happyTcHack x happyReduce_306
+
+action_307 x = happyTcHack x happyReduce_320
+
+action_308 (121#) = happyShift action_468
+action_308 (125#) = happyShift action_469
+action_308 x = happyTcHack x happyFail
+
+action_309 x = happyTcHack x happyReduce_318
+
+action_310 (173#) = happyShift action_467
+action_310 x = happyTcHack x happyFail
+
+action_311 x = happyTcHack x happyReduce_322
+
+action_312 (146#) = happyShift action_466
+action_312 x = happyTcHack x happyFail
+
+action_313 (146#) = happyShift action_465
+action_313 x = happyTcHack x happyFail
+
+action_314 (120#) = happyShift action_195
+action_314 (122#) = happyShift action_310
+action_314 (141#) = happyShift action_196
+action_314 (142#) = happyShift action_197
+action_314 (146#) = happyShift action_311
+action_314 (154#) = happyShift action_312
+action_314 (155#) = happyShift action_313
+action_314 (170#) = happyShift action_198
+action_314 (173#) = happyShift action_199
+action_314 (174#) = happyShift action_200
+action_314 (176#) = happyShift action_86
+action_314 (180#) = happyShift action_201
+action_314 (181#) = happyShift action_314
+action_314 (182#) = happyShift action_202
+action_314 (34#) = happyGoto action_307
+action_314 (35#) = happyGoto action_265
+action_314 (36#) = happyGoto action_266
+action_314 (37#) = happyGoto action_267
+action_314 (38#) = happyGoto action_268
+action_314 (39#) = happyGoto action_269
+action_314 (40#) = happyGoto action_270
+action_314 (41#) = happyGoto action_271
+action_314 (43#) = happyGoto action_272
+action_314 (44#) = happyGoto action_273
+action_314 (45#) = happyGoto action_188
+action_314 (46#) = happyGoto action_189
+action_314 (47#) = happyGoto action_190
+action_314 (48#) = happyGoto action_191
+action_314 (49#) = happyGoto action_192
+action_314 (50#) = happyGoto action_193
+action_314 (103#) = happyGoto action_464
+action_314 (114#) = happyGoto action_194
+action_314 x = happyTcHack x happyReduce_321
+
+action_315 (125#) = happyShift action_319
+action_315 (116#) = happyGoto action_463
+action_315 x = happyTcHack x happyReduce_358
+
+action_316 (120#) = happyShift action_195
+action_316 (141#) = happyShift action_196
+action_316 (142#) = happyShift action_197
+action_316 (170#) = happyShift action_198
+action_316 (173#) = happyShift action_199
+action_316 (174#) = happyShift action_200
+action_316 (176#) = happyShift action_86
+action_316 (180#) = happyShift action_201
+action_316 (182#) = happyShift action_202
+action_316 (34#) = happyGoto action_462
+action_316 (35#) = happyGoto action_265
+action_316 (36#) = happyGoto action_266
+action_316 (37#) = happyGoto action_267
+action_316 (38#) = happyGoto action_268
+action_316 (39#) = happyGoto action_269
+action_316 (40#) = happyGoto action_270
+action_316 (41#) = happyGoto action_271
+action_316 (43#) = happyGoto action_272
+action_316 (44#) = happyGoto action_273
+action_316 (45#) = happyGoto action_188
+action_316 (46#) = happyGoto action_189
+action_316 (47#) = happyGoto action_190
+action_316 (48#) = happyGoto action_191
+action_316 (49#) = happyGoto action_192
+action_316 (50#) = happyGoto action_193
+action_316 (114#) = happyGoto action_194
+action_316 x = happyTcHack x happyFail
+
+action_317 (130#) = happyShift action_461
+action_317 x = happyTcHack x happyReduce_291
+
+action_318 (123#) = happyShift action_460
+action_318 x = happyTcHack x happyFail
+
+action_319 (168#) = happyShift action_55
+action_319 (176#) = happyShift action_86
+action_319 (88#) = happyGoto action_459
+action_319 (96#) = happyGoto action_248
+action_319 (114#) = happyGoto action_249
+action_319 x = happyTcHack x happyReduce_359
+
+action_320 (146#) = happyShift action_456
+action_320 (149#) = happyShift action_43
+action_320 (150#) = happyShift action_44
+action_320 (151#) = happyShift action_45
+action_320 (152#) = happyShift action_46
+action_320 (153#) = happyShift action_47
+action_320 (156#) = happyShift action_457
+action_320 (158#) = happyShift action_52
+action_320 (159#) = happyShift action_53
+action_320 (163#) = happyShift action_54
+action_320 (176#) = happyShift action_458
+action_320 (31#) = happyGoto action_107
+action_320 (32#) = happyGoto action_452
+action_320 (59#) = happyGoto action_453
+action_320 (60#) = happyGoto action_25
+action_320 (61#) = happyGoto action_26
+action_320 (76#) = happyGoto action_454
+action_320 (86#) = happyGoto action_455
+action_320 x = happyTcHack x happyFail
+
+action_321 (123#) = happyShift action_451
+action_321 x = happyTcHack x happyFail
+
+action_322 (123#) = happyReduce_219
+action_322 (168#) = happyShift action_55
+action_322 (74#) = happyGoto action_336
+action_322 (94#) = happyGoto action_240
+action_322 (95#) = happyGoto action_219
+action_322 (96#) = happyGoto action_220
+action_322 x = happyTcHack x happyReduce_303
+
+action_323 (161#) = happyShift action_327
+action_323 (162#) = happyShift action_328
+action_323 (168#) = happyShift action_450
+action_323 (78#) = happyGoto action_449
+action_323 (81#) = happyGoto action_325
+action_323 (82#) = happyGoto action_326
+action_323 x = happyTcHack x happyReduce_218
+
+action_324 (117#) = happyShift action_448
+action_324 x = happyTcHack x happyFail
+
+action_325 (117#) = happyReduce_272
+action_325 (161#) = happyShift action_327
+action_325 (162#) = happyShift action_328
+action_325 (168#) = happyShift action_55
+action_325 (80#) = happyGoto action_445
+action_325 (82#) = happyGoto action_446
+action_325 (94#) = happyGoto action_447
+action_325 (95#) = happyGoto action_219
+action_325 (96#) = happyGoto action_220
+action_325 x = happyTcHack x happyReduce_303
+
+action_326 x = happyTcHack x happyReduce_275
+
+action_327 (120#) = happyShift action_195
+action_327 (141#) = happyShift action_196
+action_327 (142#) = happyShift action_197
+action_327 (170#) = happyShift action_198
+action_327 (173#) = happyShift action_199
+action_327 (174#) = happyShift action_200
+action_327 (176#) = happyShift action_86
+action_327 (180#) = happyShift action_201
+action_327 (182#) = happyShift action_202
+action_327 (34#) = happyGoto action_444
+action_327 (35#) = happyGoto action_265
+action_327 (36#) = happyGoto action_266
+action_327 (37#) = happyGoto action_267
+action_327 (38#) = happyGoto action_268
+action_327 (39#) = happyGoto action_269
+action_327 (40#) = happyGoto action_270
+action_327 (41#) = happyGoto action_271
+action_327 (43#) = happyGoto action_272
+action_327 (44#) = happyGoto action_273
+action_327 (45#) = happyGoto action_188
+action_327 (46#) = happyGoto action_189
+action_327 (47#) = happyGoto action_190
+action_327 (48#) = happyGoto action_191
+action_327 (49#) = happyGoto action_192
+action_327 (50#) = happyGoto action_193
+action_327 (114#) = happyGoto action_194
+action_327 x = happyTcHack x happyFail
+
+action_328 (124#) = happyShift action_443
+action_328 x = happyTcHack x happyFail
+
+action_329 (161#) = happyShift action_441
+action_329 (162#) = happyShift action_442
+action_329 (169#) = happyShift action_94
+action_329 (172#) = happyShift action_95
+action_329 (176#) = happyShift action_86
+action_329 (183#) = happyShift action_96
+action_329 (83#) = happyGoto action_440
+action_329 (97#) = happyGoto action_91
+action_329 (98#) = happyGoto action_92
+action_329 (114#) = happyGoto action_93
+action_329 x = happyTcHack x happyFail
+
+action_330 (123#) = happyShift action_439
+action_330 (168#) = happyShift action_55
+action_330 (74#) = happyGoto action_336
+action_330 (94#) = happyGoto action_240
+action_330 (95#) = happyGoto action_219
+action_330 (96#) = happyGoto action_220
+action_330 x = happyTcHack x happyReduce_303
+
+action_331 x = happyTcHack x happyReduce_233
+
+action_332 (120#) = happyShift action_148
+action_332 (124#) = happyShift action_104
+action_332 (146#) = happyShift action_105
+action_332 (168#) = happyShift action_428
+action_332 (172#) = happyShift action_106
+action_332 (175#) = happyShift action_149
+action_332 (176#) = happyShift action_86
+action_332 (181#) = happyShift action_150
+action_332 (193#) = happyShift action_69
+action_332 (63#) = happyGoto action_438
+action_332 (64#) = happyGoto action_427
+action_332 (65#) = happyGoto action_140
+action_332 (66#) = happyGoto action_141
+action_332 (67#) = happyGoto action_142
+action_332 (68#) = happyGoto action_143
+action_332 (69#) = happyGoto action_144
+action_332 (70#) = happyGoto action_145
+action_332 (71#) = happyGoto action_146
+action_332 (110#) = happyGoto action_147
+action_332 (111#) = happyGoto action_35
+action_332 (114#) = happyGoto action_102
+action_332 x = happyTcHack x happyReduce_256
+
+action_333 (1#) = happyShift action_36
+action_333 (128#) = happyShift action_157
+action_333 (129#) = happyShift action_158
+action_333 (146#) = happyShift action_40
+action_333 (147#) = happyShift action_41
+action_333 (148#) = happyShift action_42
+action_333 (149#) = happyShift action_43
+action_333 (150#) = happyShift action_44
+action_333 (151#) = happyShift action_45
+action_333 (152#) = happyShift action_46
+action_333 (153#) = happyShift action_47
+action_333 (154#) = happyShift action_48
+action_333 (155#) = happyShift action_49
+action_333 (156#) = happyShift action_50
+action_333 (157#) = happyShift action_51
+action_333 (158#) = happyShift action_52
+action_333 (159#) = happyShift action_53
+action_333 (163#) = happyShift action_54
+action_333 (171#) = happyShift action_56
+action_333 (176#) = happyShift action_57
+action_333 (197#) = happyShift action_73
+action_333 (31#) = happyGoto action_18
+action_333 (32#) = happyGoto action_19
+action_333 (52#) = happyGoto action_437
+action_333 (54#) = happyGoto action_333
+action_333 (55#) = happyGoto action_334
+action_333 (59#) = happyGoto action_76
+action_333 (60#) = happyGoto action_25
+action_333 (61#) = happyGoto action_26
+action_333 (86#) = happyGoto action_77
+action_333 x = happyTcHack x happyFail
+
+action_334 (128#) = happyShift action_157
+action_334 (129#) = happyShift action_158
+action_334 (54#) = happyGoto action_436
+action_334 x = happyTcHack x happyReduce_171
+
+action_335 (117#) = happyShift action_435
+action_335 x = happyTcHack x happyFail
+
+action_336 (193#) = happyShift action_69
+action_336 (109#) = happyGoto action_434
+action_336 (110#) = happyGoto action_34
+action_336 (111#) = happyGoto action_35
+action_336 x = happyTcHack x happyReduce_344
+
+action_337 (193#) = happyShift action_69
+action_337 (109#) = happyGoto action_433
+action_337 (110#) = happyGoto action_34
+action_337 (111#) = happyGoto action_35
+action_337 x = happyTcHack x happyReduce_344
+
+action_338 x = happyTcHack x happyReduce_234
+
+action_339 x = happyTcHack x happyReduce_80
+
+action_340 (120#) = happyShift action_195
+action_340 (141#) = happyShift action_196
+action_340 (142#) = happyShift action_197
+action_340 (170#) = happyShift action_198
+action_340 (173#) = happyShift action_199
+action_340 (174#) = happyShift action_200
+action_340 (176#) = happyShift action_86
+action_340 (180#) = happyShift action_201
+action_340 (182#) = happyShift action_202
+action_340 (34#) = happyGoto action_432
+action_340 (35#) = happyGoto action_265
+action_340 (36#) = happyGoto action_266
+action_340 (37#) = happyGoto action_267
+action_340 (38#) = happyGoto action_268
+action_340 (39#) = happyGoto action_269
+action_340 (40#) = happyGoto action_270
+action_340 (41#) = happyGoto action_271
+action_340 (43#) = happyGoto action_272
+action_340 (44#) = happyGoto action_273
+action_340 (45#) = happyGoto action_188
+action_340 (46#) = happyGoto action_189
+action_340 (47#) = happyGoto action_190
+action_340 (48#) = happyGoto action_191
+action_340 (49#) = happyGoto action_192
+action_340 (50#) = happyGoto action_193
+action_340 (114#) = happyGoto action_194
+action_340 x = happyTcHack x happyFail
+
+action_341 x = happyTcHack x happyReduce_86
+
+action_342 x = happyTcHack x happyReduce_87
+
+action_343 (1#) = happyShift action_431
+action_343 (117#) = happyShift action_167
+action_343 (118#) = happyShift action_37
+action_343 (119#) = happyShift action_38
+action_343 (128#) = happyShift action_39
+action_343 (144#) = happyReduce_344
+action_343 (145#) = happyReduce_344
+action_343 (146#) = happyShift action_40
+action_343 (147#) = happyShift action_41
+action_343 (148#) = happyShift action_42
+action_343 (149#) = happyShift action_43
+action_343 (150#) = happyShift action_44
+action_343 (151#) = happyShift action_45
+action_343 (152#) = happyShift action_46
+action_343 (153#) = happyShift action_47
+action_343 (154#) = happyShift action_48
+action_343 (155#) = happyShift action_49
+action_343 (156#) = happyShift action_50
+action_343 (157#) = happyShift action_51
+action_343 (158#) = happyShift action_52
+action_343 (159#) = happyShift action_53
+action_343 (163#) = happyShift action_54
+action_343 (168#) = happyShift action_55
+action_343 (171#) = happyShift action_56
+action_343 (176#) = happyShift action_57
+action_343 (177#) = happyShift action_58
+action_343 (178#) = happyShift action_59
+action_343 (179#) = happyShift action_60
+action_343 (183#) = happyShift action_61
+action_343 (184#) = happyShift action_62
+action_343 (187#) = happyShift action_63
+action_343 (188#) = happyShift action_64
+action_343 (189#) = happyShift action_65
+action_343 (190#) = happyShift action_66
+action_343 (191#) = happyShift action_67
+action_343 (192#) = happyShift action_68
+action_343 (193#) = happyShift action_69
+action_343 (194#) = happyShift action_70
+action_343 (195#) = happyShift action_71
+action_343 (196#) = happyShift action_72
+action_343 (197#) = happyShift action_73
+action_343 (9#) = happyGoto action_6
+action_343 (10#) = happyGoto action_7
+action_343 (11#) = happyGoto action_8
+action_343 (12#) = happyGoto action_9
+action_343 (17#) = happyGoto action_10
+action_343 (18#) = happyGoto action_11
+action_343 (19#) = happyGoto action_12
+action_343 (20#) = happyGoto action_13
+action_343 (21#) = happyGoto action_14
+action_343 (26#) = happyGoto action_15
+action_343 (27#) = happyGoto action_16
+action_343 (28#) = happyGoto action_17
+action_343 (31#) = happyGoto action_18
+action_343 (32#) = happyGoto action_19
+action_343 (51#) = happyGoto action_20
+action_343 (53#) = happyGoto action_21
+action_343 (55#) = happyGoto action_22
+action_343 (58#) = happyGoto action_23
+action_343 (59#) = happyGoto action_24
+action_343 (60#) = happyGoto action_25
+action_343 (61#) = happyGoto action_26
+action_343 (86#) = happyGoto action_27
+action_343 (89#) = happyGoto action_28
+action_343 (90#) = happyGoto action_29
+action_343 (93#) = happyGoto action_30
+action_343 (96#) = happyGoto action_31
+action_343 (104#) = happyGoto action_32
+action_343 (109#) = happyGoto action_33
+action_343 (110#) = happyGoto action_34
+action_343 (111#) = happyGoto action_35
+action_343 (115#) = happyGoto action_430
+action_343 x = happyTcHack x happyFail
+
+action_344 x = happyTcHack x happyReduce_304
+
+action_345 (120#) = happyShift action_148
+action_345 (124#) = happyShift action_104
+action_345 (146#) = happyShift action_105
+action_345 (168#) = happyShift action_428
+action_345 (172#) = happyShift action_106
+action_345 (175#) = happyShift action_149
+action_345 (176#) = happyShift action_86
+action_345 (181#) = happyShift action_150
+action_345 (193#) = happyShift action_69
+action_345 (63#) = happyGoto action_429
+action_345 (64#) = happyGoto action_427
+action_345 (65#) = happyGoto action_140
+action_345 (66#) = happyGoto action_141
+action_345 (67#) = happyGoto action_142
+action_345 (68#) = happyGoto action_143
+action_345 (69#) = happyGoto action_144
+action_345 (70#) = happyGoto action_145
+action_345 (71#) = happyGoto action_146
+action_345 (110#) = happyGoto action_147
+action_345 (111#) = happyGoto action_35
+action_345 (114#) = happyGoto action_102
+action_345 x = happyTcHack x happyFail
+
+action_346 (120#) = happyShift action_148
+action_346 (124#) = happyShift action_104
+action_346 (146#) = happyShift action_105
+action_346 (168#) = happyShift action_428
+action_346 (172#) = happyShift action_106
+action_346 (175#) = happyShift action_149
+action_346 (176#) = happyShift action_86
+action_346 (181#) = happyShift action_150
+action_346 (193#) = happyShift action_69
+action_346 (63#) = happyGoto action_426
+action_346 (64#) = happyGoto action_427
+action_346 (65#) = happyGoto action_140
+action_346 (66#) = happyGoto action_141
+action_346 (67#) = happyGoto action_142
+action_346 (68#) = happyGoto action_143
+action_346 (69#) = happyGoto action_144
+action_346 (70#) = happyGoto action_145
+action_346 (71#) = happyGoto action_146
+action_346 (110#) = happyGoto action_147
+action_346 (111#) = happyGoto action_35
+action_346 (114#) = happyGoto action_102
+action_346 x = happyTcHack x happyFail
+
+action_347 (169#) = happyShift action_425
+action_347 x = happyTcHack x happyFail
+
+action_348 (126#) = happyShift action_424
+action_348 x = happyTcHack x happyReduce_154
+
+action_349 x = happyTcHack x happyReduce_241
+
+action_350 (169#) = happyShift action_423
+action_350 x = happyTcHack x happyFail
+
+action_351 (1#) = happyShift action_36
+action_351 (128#) = happyShift action_157
+action_351 (129#) = happyShift action_158
+action_351 (146#) = happyShift action_40
+action_351 (147#) = happyShift action_41
+action_351 (148#) = happyShift action_42
+action_351 (149#) = happyShift action_43
+action_351 (150#) = happyShift action_44
+action_351 (151#) = happyShift action_45
+action_351 (152#) = happyShift action_46
+action_351 (153#) = happyShift action_47
+action_351 (154#) = happyShift action_48
+action_351 (155#) = happyShift action_49
+action_351 (156#) = happyShift action_50
+action_351 (157#) = happyShift action_51
+action_351 (158#) = happyShift action_52
+action_351 (159#) = happyShift action_53
+action_351 (163#) = happyShift action_54
+action_351 (171#) = happyShift action_56
+action_351 (176#) = happyShift action_57
+action_351 (197#) = happyShift action_73
+action_351 (31#) = happyGoto action_18
+action_351 (32#) = happyGoto action_19
+action_351 (52#) = happyGoto action_422
+action_351 (54#) = happyGoto action_333
+action_351 (55#) = happyGoto action_334
+action_351 (59#) = happyGoto action_76
+action_351 (60#) = happyGoto action_25
+action_351 (61#) = happyGoto action_26
+action_351 (86#) = happyGoto action_77
+action_351 x = happyTcHack x happyFail
+
+action_352 x = happyTcHack x happyReduce_333
+
+action_353 (121#) = happyShift action_420
+action_353 (125#) = happyShift action_421
+action_353 x = happyTcHack x happyFail
+
+action_354 x = happyTcHack x happyReduce_246
+
+action_355 x = happyTcHack x happyReduce_332
+
+action_356 (120#) = happyShift action_212
+action_356 (168#) = happyShift action_213
+action_356 x = happyTcHack x happyReduce_239
+
+action_357 (120#) = happyShift action_212
+action_357 (168#) = happyShift action_213
+action_357 x = happyTcHack x happyReduce_240
+
+action_358 x = happyTcHack x happyReduce_229
+
+action_359 x = happyTcHack x happyReduce_252
+
+action_360 x = happyTcHack x happyReduce_250
+
+action_361 (130#) = happyShift action_419
+action_361 x = happyTcHack x happyFail
+
+action_362 (1#) = happyShift action_122
+action_362 (146#) = happyShift action_123
+action_362 (147#) = happyShift action_124
+action_362 (148#) = happyShift action_125
+action_362 (149#) = happyShift action_43
+action_362 (150#) = happyShift action_44
+action_362 (151#) = happyShift action_45
+action_362 (152#) = happyShift action_46
+action_362 (153#) = happyShift action_47
+action_362 (154#) = happyShift action_126
+action_362 (155#) = happyShift action_127
+action_362 (156#) = happyShift action_128
+action_362 (157#) = happyShift action_129
+action_362 (171#) = happyShift action_130
+action_362 (176#) = happyShift action_131
+action_362 (183#) = happyShift action_61
+action_362 (184#) = happyShift action_62
+action_362 (30#) = happyGoto action_418
+action_362 (31#) = happyGoto action_119
+action_362 (32#) = happyGoto action_120
+action_362 (89#) = happyGoto action_121
+action_362 (90#) = happyGoto action_29
+action_362 x = happyTcHack x happyFail
+
+action_363 (168#) = happyShift action_417
+action_363 x = happyTcHack x happyFail
+
+action_364 (153#) = happyShift action_161
+action_364 (154#) = happyShift action_415
+action_364 (155#) = happyShift action_416
+action_364 x = happyTcHack x happyReduce_99
+
+action_365 (168#) = happyReduce_71
+action_365 x = happyTcHack x happyReduce_102
+
+action_366 (121#) = happyShift action_414
+action_366 x = happyTcHack x happyFail
+
+action_367 (121#) = happyShift action_413
+action_367 x = happyTcHack x happyFail
+
+action_368 (168#) = happyReduce_79
+action_368 x = happyTcHack x happyReduce_107
+
+action_369 (168#) = happyReduce_93
+action_369 x = happyTcHack x happyReduce_120
+
+action_370 (168#) = happyReduce_90
+action_370 (181#) = happyShift action_229
+action_370 x = happyTcHack x happyReduce_117
+
+action_371 (168#) = happyReduce_92
+action_371 x = happyTcHack x happyReduce_119
+
+action_372 (168#) = happyReduce_74
+action_372 x = happyTcHack x happyReduce_105
+
+action_373 (149#) = happyShift action_43
+action_373 (150#) = happyShift action_44
+action_373 (151#) = happyShift action_45
+action_373 (152#) = happyShift action_46
+action_373 (153#) = happyShift action_47
+action_373 (156#) = happyShift action_412
+action_373 (168#) = happyReduce_82
+action_373 (31#) = happyGoto action_107
+action_373 (32#) = happyGoto action_411
+action_373 x = happyTcHack x happyReduce_110
+
+action_374 (149#) = happyShift action_43
+action_374 (150#) = happyShift action_44
+action_374 (151#) = happyShift action_45
+action_374 (152#) = happyShift action_46
+action_374 (153#) = happyShift action_47
+action_374 (156#) = happyShift action_410
+action_374 (168#) = happyReduce_81
+action_374 (31#) = happyGoto action_107
+action_374 (32#) = happyGoto action_409
+action_374 x = happyTcHack x happyReduce_109
+
+action_375 (168#) = happyReduce_72
+action_375 (181#) = happyShift action_224
+action_375 x = happyTcHack x happyReduce_103
+
+action_376 (168#) = happyReduce_73
+action_376 (181#) = happyShift action_223
+action_376 x = happyTcHack x happyReduce_104
+
+action_377 (168#) = happyReduce_75
+action_377 (181#) = happyShift action_408
+action_377 x = happyTcHack x happyReduce_106
+
+action_378 (168#) = happyReduce_89
+action_378 x = happyTcHack x happyReduce_355
+
+action_379 x = happyTcHack x happyReduce_156
+
+action_380 (120#) = happyShift action_195
+action_380 (141#) = happyShift action_196
+action_380 (142#) = happyShift action_197
+action_380 (170#) = happyShift action_198
+action_380 (173#) = happyShift action_199
+action_380 (174#) = happyShift action_200
+action_380 (176#) = happyShift action_86
+action_380 (180#) = happyShift action_201
+action_380 (182#) = happyShift action_202
+action_380 (34#) = happyGoto action_367
+action_380 (35#) = happyGoto action_265
+action_380 (36#) = happyGoto action_266
+action_380 (37#) = happyGoto action_267
+action_380 (38#) = happyGoto action_268
+action_380 (39#) = happyGoto action_269
+action_380 (40#) = happyGoto action_270
+action_380 (41#) = happyGoto action_271
+action_380 (43#) = happyGoto action_272
+action_380 (44#) = happyGoto action_273
+action_380 (45#) = happyGoto action_188
+action_380 (46#) = happyGoto action_189
+action_380 (47#) = happyGoto action_190
+action_380 (48#) = happyGoto action_191
+action_380 (49#) = happyGoto action_192
+action_380 (50#) = happyGoto action_193
+action_380 (114#) = happyGoto action_194
+action_380 x = happyTcHack x happyFail
+
+action_381 (120#) = happyShift action_195
+action_381 (141#) = happyShift action_196
+action_381 (142#) = happyShift action_197
+action_381 (170#) = happyShift action_198
+action_381 (173#) = happyShift action_199
+action_381 (174#) = happyShift action_200
+action_381 (176#) = happyShift action_86
+action_381 (180#) = happyShift action_201
+action_381 (182#) = happyShift action_202
+action_381 (47#) = happyGoto action_407
+action_381 (48#) = happyGoto action_191
+action_381 (49#) = happyGoto action_192
+action_381 (50#) = happyGoto action_193
+action_381 (114#) = happyGoto action_194
+action_381 x = happyTcHack x happyFail
+
+action_382 (120#) = happyShift action_195
+action_382 (141#) = happyShift action_196
+action_382 (142#) = happyShift action_197
+action_382 (170#) = happyShift action_198
+action_382 (173#) = happyShift action_199
+action_382 (174#) = happyShift action_200
+action_382 (176#) = happyShift action_86
+action_382 (180#) = happyShift action_201
+action_382 (182#) = happyShift action_202
+action_382 (47#) = happyGoto action_406
+action_382 (48#) = happyGoto action_191
+action_382 (49#) = happyGoto action_192
+action_382 (50#) = happyGoto action_193
+action_382 (114#) = happyGoto action_194
+action_382 x = happyTcHack x happyFail
+
+action_383 (120#) = happyShift action_195
+action_383 (141#) = happyShift action_196
+action_383 (142#) = happyShift action_197
+action_383 (170#) = happyShift action_198
+action_383 (173#) = happyShift action_199
+action_383 (174#) = happyShift action_200
+action_383 (176#) = happyShift action_86
+action_383 (180#) = happyShift action_201
+action_383 (182#) = happyShift action_202
+action_383 (47#) = happyGoto action_405
+action_383 (48#) = happyGoto action_191
+action_383 (49#) = happyGoto action_192
+action_383 (50#) = happyGoto action_193
+action_383 (114#) = happyGoto action_194
+action_383 x = happyTcHack x happyFail
+
+action_384 (120#) = happyShift action_195
+action_384 (141#) = happyShift action_196
+action_384 (142#) = happyShift action_197
+action_384 (170#) = happyShift action_198
+action_384 (173#) = happyShift action_199
+action_384 (174#) = happyShift action_200
+action_384 (176#) = happyShift action_86
+action_384 (180#) = happyShift action_201
+action_384 (182#) = happyShift action_202
+action_384 (46#) = happyGoto action_404
+action_384 (47#) = happyGoto action_190
+action_384 (48#) = happyGoto action_191
+action_384 (49#) = happyGoto action_192
+action_384 (50#) = happyGoto action_193
+action_384 (114#) = happyGoto action_194
+action_384 x = happyTcHack x happyFail
+
+action_385 (120#) = happyShift action_195
+action_385 (141#) = happyShift action_196
+action_385 (142#) = happyShift action_197
+action_385 (170#) = happyShift action_198
+action_385 (173#) = happyShift action_199
+action_385 (174#) = happyShift action_200
+action_385 (176#) = happyShift action_86
+action_385 (180#) = happyShift action_201
+action_385 (182#) = happyShift action_202
+action_385 (46#) = happyGoto action_403
+action_385 (47#) = happyGoto action_190
+action_385 (48#) = happyGoto action_191
+action_385 (49#) = happyGoto action_192
+action_385 (50#) = happyGoto action_193
+action_385 (114#) = happyGoto action_194
+action_385 x = happyTcHack x happyFail
+
+action_386 x = happyTcHack x happyReduce_294
+
+action_387 (13#) = happyGoto action_402
+action_387 x = happyTcHack x happyReduce_31
+
+action_388 (117#) = happyShift action_401
+action_388 x = happyTcHack x happyFail
+
+action_389 (1#) = happyShift action_36
+action_389 (123#) = happyShift action_400
+action_389 (128#) = happyShift action_39
+action_389 (144#) = happyReduce_344
+action_389 (145#) = happyReduce_344
+action_389 (146#) = happyShift action_40
+action_389 (147#) = happyShift action_41
+action_389 (148#) = happyShift action_42
+action_389 (149#) = happyShift action_43
+action_389 (150#) = happyShift action_44
+action_389 (151#) = happyShift action_45
+action_389 (152#) = happyShift action_46
+action_389 (153#) = happyShift action_47
+action_389 (154#) = happyShift action_48
+action_389 (155#) = happyShift action_49
+action_389 (156#) = happyShift action_50
+action_389 (157#) = happyShift action_51
+action_389 (158#) = happyShift action_52
+action_389 (159#) = happyShift action_53
+action_389 (163#) = happyShift action_54
+action_389 (168#) = happyShift action_55
+action_389 (171#) = happyShift action_56
+action_389 (176#) = happyShift action_57
+action_389 (183#) = happyShift action_61
+action_389 (184#) = happyShift action_62
+action_389 (187#) = happyShift action_63
+action_389 (188#) = happyShift action_64
+action_389 (189#) = happyShift action_65
+action_389 (190#) = happyShift action_66
+action_389 (193#) = happyShift action_69
+action_389 (194#) = happyShift action_70
+action_389 (197#) = happyShift action_73
+action_389 (20#) = happyGoto action_392
+action_389 (21#) = happyGoto action_393
+action_389 (23#) = happyGoto action_394
+action_389 (24#) = happyGoto action_395
+action_389 (26#) = happyGoto action_396
+action_389 (31#) = happyGoto action_18
+action_389 (32#) = happyGoto action_19
+action_389 (51#) = happyGoto action_397
+action_389 (53#) = happyGoto action_21
+action_389 (55#) = happyGoto action_22
+action_389 (58#) = happyGoto action_23
+action_389 (59#) = happyGoto action_24
+action_389 (60#) = happyGoto action_25
+action_389 (61#) = happyGoto action_26
+action_389 (86#) = happyGoto action_27
+action_389 (89#) = happyGoto action_28
+action_389 (90#) = happyGoto action_29
+action_389 (93#) = happyGoto action_398
+action_389 (96#) = happyGoto action_399
+action_389 (104#) = happyGoto action_32
+action_389 (109#) = happyGoto action_33
+action_389 (110#) = happyGoto action_34
+action_389 (111#) = happyGoto action_35
+action_389 x = happyTcHack x happyFail
+
+action_390 x = happyTcHack x happyReduce_8
+
+action_391 x = happyTcHack x happyReduce_7
+
+action_392 (1#) = happyShift action_166
+action_392 (117#) = happyShift action_167
+action_392 (115#) = happyGoto action_546
+action_392 x = happyTcHack x happyFail
+
+action_393 (1#) = happyShift action_166
+action_393 (117#) = happyShift action_167
+action_393 (115#) = happyGoto action_545
+action_393 x = happyTcHack x happyFail
+
+action_394 x = happyTcHack x happyReduce_52
+
+action_395 (117#) = happyShift action_544
+action_395 x = happyTcHack x happyFail
+
+action_396 (117#) = happyShift action_543
+action_396 x = happyTcHack x happyFail
+
+action_397 (117#) = happyShift action_542
+action_397 x = happyTcHack x happyFail
+
+action_398 x = happyTcHack x happyReduce_59
+
+action_399 (1#) = happyShift action_36
+action_399 (128#) = happyShift action_153
+action_399 (146#) = happyShift action_40
+action_399 (147#) = happyShift action_41
+action_399 (148#) = happyShift action_42
+action_399 (149#) = happyShift action_43
+action_399 (150#) = happyShift action_44
+action_399 (151#) = happyShift action_45
+action_399 (152#) = happyShift action_46
+action_399 (153#) = happyShift action_47
+action_399 (154#) = happyShift action_48
+action_399 (155#) = happyShift action_49
+action_399 (156#) = happyShift action_50
+action_399 (157#) = happyShift action_51
+action_399 (158#) = happyShift action_52
+action_399 (159#) = happyShift action_53
+action_399 (163#) = happyShift action_54
+action_399 (171#) = happyShift action_56
+action_399 (176#) = happyShift action_57
+action_399 (183#) = happyShift action_61
+action_399 (184#) = happyShift action_62
+action_399 (197#) = happyShift action_73
+action_399 (31#) = happyGoto action_18
+action_399 (32#) = happyGoto action_19
+action_399 (53#) = happyGoto action_21
+action_399 (55#) = happyGoto action_22
+action_399 (58#) = happyGoto action_152
+action_399 (59#) = happyGoto action_24
+action_399 (60#) = happyGoto action_25
+action_399 (61#) = happyGoto action_26
+action_399 (86#) = happyGoto action_27
+action_399 (89#) = happyGoto action_28
+action_399 (90#) = happyGoto action_29
+action_399 (93#) = happyGoto action_541
+action_399 (104#) = happyGoto action_32
+action_399 x = happyTcHack x happyFail
+
+action_400 x = happyTcHack x happyReduce_42
+
+action_401 (123#) = happyShift action_540
+action_401 x = happyTcHack x happyFail
+
+action_402 (168#) = happyShift action_55
+action_402 (185#) = happyShift action_539
+action_402 (94#) = happyGoto action_538
+action_402 (95#) = happyGoto action_219
+action_402 (96#) = happyGoto action_220
+action_402 x = happyTcHack x happyReduce_303
+
+action_403 (139#) = happyShift action_381
+action_403 (140#) = happyShift action_382
+action_403 (181#) = happyShift action_383
+action_403 x = happyTcHack x happyReduce_147
+
+action_404 (139#) = happyShift action_381
+action_404 (140#) = happyShift action_382
+action_404 (181#) = happyShift action_383
+action_404 x = happyTcHack x happyReduce_146
+
+action_405 x = happyTcHack x happyReduce_149
+
+action_406 x = happyTcHack x happyReduce_151
+
+action_407 x = happyTcHack x happyReduce_150
+
+action_408 (168#) = happyReduce_76
+action_408 x = happyTcHack x happyReduce_118
+
+action_409 (168#) = happyReduce_84
+action_409 x = happyTcHack x happyReduce_112
+
+action_410 (168#) = happyReduce_88
+action_410 x = happyTcHack x happyReduce_116
+
+action_411 (168#) = happyReduce_83
+action_411 x = happyTcHack x happyReduce_111
+
+action_412 (168#) = happyReduce_85
+action_412 x = happyTcHack x happyReduce_115
+
+action_413 x = happyTcHack x happyReduce_164
+
+action_414 (120#) = happyShift action_195
+action_414 (141#) = happyShift action_196
+action_414 (142#) = happyShift action_197
+action_414 (170#) = happyShift action_198
+action_414 (173#) = happyShift action_199
+action_414 (174#) = happyShift action_200
+action_414 (176#) = happyShift action_86
+action_414 (180#) = happyShift action_201
+action_414 (182#) = happyShift action_202
+action_414 (47#) = happyGoto action_537
+action_414 (48#) = happyGoto action_191
+action_414 (49#) = happyGoto action_192
+action_414 (50#) = happyGoto action_193
+action_414 (114#) = happyGoto action_194
+action_414 x = happyTcHack x happyFail
+
+action_415 (153#) = happyShift action_536
+action_415 x = happyTcHack x happyFail
+
+action_416 (153#) = happyShift action_535
+action_416 x = happyTcHack x happyFail
+
+action_417 (169#) = happyShift action_534
+action_417 x = happyTcHack x happyFail
+
+action_418 (121#) = happyShift action_533
+action_418 (168#) = happyShift action_233
+action_418 x = happyTcHack x happyFail
+
+action_419 (120#) = happyShift action_195
+action_419 (141#) = happyShift action_196
+action_419 (142#) = happyShift action_197
+action_419 (170#) = happyShift action_198
+action_419 (173#) = happyShift action_199
+action_419 (174#) = happyShift action_200
+action_419 (176#) = happyShift action_86
+action_419 (180#) = happyShift action_201
+action_419 (182#) = happyShift action_202
+action_419 (34#) = happyGoto action_532
+action_419 (35#) = happyGoto action_265
+action_419 (36#) = happyGoto action_266
+action_419 (37#) = happyGoto action_267
+action_419 (38#) = happyGoto action_268
+action_419 (39#) = happyGoto action_269
+action_419 (40#) = happyGoto action_270
+action_419 (41#) = happyGoto action_271
+action_419 (43#) = happyGoto action_272
+action_419 (44#) = happyGoto action_273
+action_419 (45#) = happyGoto action_188
+action_419 (46#) = happyGoto action_189
+action_419 (47#) = happyGoto action_190
+action_419 (48#) = happyGoto action_191
+action_419 (49#) = happyGoto action_192
+action_419 (50#) = happyGoto action_193
+action_419 (114#) = happyGoto action_194
+action_419 x = happyTcHack x happyFail
+
+action_420 x = happyTcHack x happyReduce_245
+
+action_421 (127#) = happyShift action_355
+action_421 (168#) = happyShift action_55
+action_421 (94#) = happyGoto action_351
+action_421 (95#) = happyGoto action_219
+action_421 (96#) = happyGoto action_220
+action_421 (105#) = happyGoto action_531
+action_421 x = happyTcHack x happyReduce_303
+
+action_422 (120#) = happyShift action_530
+action_422 (124#) = happyShift action_104
+action_422 (146#) = happyShift action_105
+action_422 (168#) = happyShift action_428
+action_422 (172#) = happyShift action_106
+action_422 (175#) = happyShift action_149
+action_422 (176#) = happyShift action_86
+action_422 (181#) = happyShift action_150
+action_422 (193#) = happyShift action_69
+action_422 (64#) = happyGoto action_525
+action_422 (65#) = happyGoto action_526
+action_422 (66#) = happyGoto action_141
+action_422 (67#) = happyGoto action_142
+action_422 (68#) = happyGoto action_143
+action_422 (69#) = happyGoto action_144
+action_422 (70#) = happyGoto action_145
+action_422 (71#) = happyGoto action_527
+action_422 (107#) = happyGoto action_528
+action_422 (108#) = happyGoto action_529
+action_422 (110#) = happyGoto action_147
+action_422 (111#) = happyGoto action_35
+action_422 (114#) = happyGoto action_102
+action_422 x = happyTcHack x happyReduce_329
+
+action_423 x = happyTcHack x happyReduce_242
+
+action_424 (126#) = happyShift action_524
+action_424 x = happyTcHack x happyFail
+
+action_425 x = happyTcHack x happyReduce_243
+
+action_426 (125#) = happyShift action_517
+action_426 (193#) = happyShift action_69
+action_426 (109#) = happyGoto action_523
+action_426 (110#) = happyGoto action_34
+action_426 (111#) = happyGoto action_35
+action_426 x = happyTcHack x happyReduce_344
+
+action_427 x = happyTcHack x happyReduce_220
+
+action_428 (120#) = happyShift action_195
+action_428 (141#) = happyShift action_196
+action_428 (142#) = happyShift action_197
+action_428 (169#) = happyShift action_522
+action_428 (170#) = happyShift action_198
+action_428 (173#) = happyShift action_199
+action_428 (174#) = happyShift action_200
+action_428 (176#) = happyShift action_86
+action_428 (180#) = happyShift action_201
+action_428 (182#) = happyShift action_202
+action_428 (34#) = happyGoto action_521
+action_428 (35#) = happyGoto action_265
+action_428 (36#) = happyGoto action_266
+action_428 (37#) = happyGoto action_267
+action_428 (38#) = happyGoto action_268
+action_428 (39#) = happyGoto action_269
+action_428 (40#) = happyGoto action_270
+action_428 (41#) = happyGoto action_271
+action_428 (43#) = happyGoto action_272
+action_428 (44#) = happyGoto action_273
+action_428 (45#) = happyGoto action_188
+action_428 (46#) = happyGoto action_189
+action_428 (47#) = happyGoto action_190
+action_428 (48#) = happyGoto action_191
+action_428 (49#) = happyGoto action_192
+action_428 (50#) = happyGoto action_193
+action_428 (114#) = happyGoto action_194
+action_428 x = happyTcHack x happyFail
+
+action_429 (125#) = happyShift action_517
+action_429 (193#) = happyShift action_69
+action_429 (109#) = happyGoto action_520
+action_429 (110#) = happyGoto action_34
+action_429 (111#) = happyGoto action_35
+action_429 x = happyTcHack x happyReduce_344
+
+action_430 (123#) = happyShift action_519
+action_430 x = happyTcHack x happyFail
+
+action_431 (123#) = happyReduce_356
+action_431 x = happyTcHack x happyReduce_200
+
+action_432 x = happyTcHack x happyReduce_169
+
+action_433 x = happyTcHack x happyReduce_213
+
+action_434 (117#) = happyShift action_518
+action_434 x = happyTcHack x happyFail
+
+action_435 x = happyTcHack x happyReduce_253
+
+action_436 x = happyTcHack x happyReduce_174
+
+action_437 (168#) = happyShift action_428
+action_437 x = happyTcHack x happyReduce_175
+
+action_438 (125#) = happyShift action_517
+action_438 x = happyTcHack x happyReduce_255
+
+action_439 (193#) = happyShift action_69
+action_439 (109#) = happyGoto action_516
+action_439 (110#) = happyGoto action_34
+action_439 (111#) = happyGoto action_35
+action_439 x = happyTcHack x happyReduce_344
+
+action_440 (169#) = happyShift action_515
+action_440 x = happyTcHack x happyFail
+
+action_441 (120#) = happyShift action_514
+action_441 x = happyTcHack x happyFail
+
+action_442 x = happyTcHack x happyReduce_280
+
+action_443 x = happyTcHack x happyReduce_278
+
+action_444 (124#) = happyShift action_513
+action_444 x = happyTcHack x happyFail
+
+action_445 x = happyTcHack x happyReduce_267
+
+action_446 x = happyTcHack x happyReduce_276
+
+action_447 (1#) = happyShift action_36
+action_447 (128#) = happyShift action_157
+action_447 (129#) = happyShift action_158
+action_447 (146#) = happyShift action_40
+action_447 (147#) = happyShift action_41
+action_447 (148#) = happyShift action_42
+action_447 (149#) = happyShift action_43
+action_447 (150#) = happyShift action_44
+action_447 (151#) = happyShift action_45
+action_447 (152#) = happyShift action_46
+action_447 (153#) = happyShift action_47
+action_447 (154#) = happyShift action_48
+action_447 (155#) = happyShift action_49
+action_447 (156#) = happyShift action_50
+action_447 (157#) = happyShift action_51
+action_447 (158#) = happyShift action_52
+action_447 (159#) = happyShift action_53
+action_447 (163#) = happyShift action_54
+action_447 (171#) = happyShift action_56
+action_447 (176#) = happyShift action_57
+action_447 (197#) = happyShift action_73
+action_447 (31#) = happyGoto action_18
+action_447 (32#) = happyGoto action_19
+action_447 (52#) = happyGoto action_512
+action_447 (54#) = happyGoto action_333
+action_447 (55#) = happyGoto action_334
+action_447 (59#) = happyGoto action_76
+action_447 (60#) = happyGoto action_25
+action_447 (61#) = happyGoto action_26
+action_447 (86#) = happyGoto action_77
+action_447 x = happyTcHack x happyFail
+
+action_448 x = happyTcHack x happyReduce_265
+
+action_449 (117#) = happyShift action_511
+action_449 x = happyTcHack x happyFail
+
+action_450 (161#) = happyShift action_441
+action_450 (162#) = happyShift action_442
+action_450 (83#) = happyGoto action_440
+action_450 x = happyTcHack x happyFail
+
+action_451 (193#) = happyShift action_69
+action_451 (109#) = happyGoto action_510
+action_451 (110#) = happyGoto action_34
+action_451 (111#) = happyGoto action_35
+action_451 x = happyTcHack x happyReduce_344
+
+action_452 x = happyTcHack x happyReduce_259
+
+action_453 x = happyTcHack x happyReduce_262
+
+action_454 (176#) = happyShift action_86
+action_454 (114#) = happyGoto action_509
+action_454 x = happyTcHack x happyFail
+
+action_455 x = happyTcHack x happyReduce_261
+
+action_456 x = happyTcHack x happyReduce_264
+
+action_457 x = happyTcHack x happyReduce_260
+
+action_458 x = happyTcHack x happyReduce_263
+
+action_459 x = happyTcHack x happyReduce_289
+
+action_460 x = happyTcHack x happyReduce_285
+
+action_461 (120#) = happyShift action_195
+action_461 (141#) = happyShift action_196
+action_461 (142#) = happyShift action_197
+action_461 (170#) = happyShift action_198
+action_461 (173#) = happyShift action_199
+action_461 (174#) = happyShift action_200
+action_461 (176#) = happyShift action_86
+action_461 (180#) = happyShift action_201
+action_461 (182#) = happyShift action_202
+action_461 (34#) = happyGoto action_508
+action_461 (35#) = happyGoto action_265
+action_461 (36#) = happyGoto action_266
+action_461 (37#) = happyGoto action_267
+action_461 (38#) = happyGoto action_268
+action_461 (39#) = happyGoto action_269
+action_461 (40#) = happyGoto action_270
+action_461 (41#) = happyGoto action_271
+action_461 (43#) = happyGoto action_272
+action_461 (44#) = happyGoto action_273
+action_461 (45#) = happyGoto action_188
+action_461 (46#) = happyGoto action_189
+action_461 (47#) = happyGoto action_190
+action_461 (48#) = happyGoto action_191
+action_461 (49#) = happyGoto action_192
+action_461 (50#) = happyGoto action_193
+action_461 (114#) = happyGoto action_194
+action_461 x = happyTcHack x happyFail
+
+action_462 x = happyTcHack x happyReduce_292
+
+action_463 (123#) = happyShift action_507
+action_463 x = happyTcHack x happyFail
+
+action_464 x = happyTcHack x happyReduce_326
+
+action_465 x = happyTcHack x happyReduce_324
+
+action_466 x = happyTcHack x happyReduce_323
+
+action_467 (123#) = happyShift action_506
+action_467 x = happyTcHack x happyFail
+
+action_468 x = happyTcHack x happyReduce_317
+
+action_469 (120#) = happyShift action_195
+action_469 (122#) = happyShift action_310
+action_469 (141#) = happyShift action_196
+action_469 (142#) = happyShift action_197
+action_469 (146#) = happyShift action_311
+action_469 (154#) = happyShift action_312
+action_469 (155#) = happyShift action_313
+action_469 (170#) = happyShift action_198
+action_469 (173#) = happyShift action_199
+action_469 (174#) = happyShift action_200
+action_469 (176#) = happyShift action_86
+action_469 (180#) = happyShift action_201
+action_469 (181#) = happyShift action_314
+action_469 (182#) = happyShift action_202
+action_469 (34#) = happyGoto action_307
+action_469 (35#) = happyGoto action_265
+action_469 (36#) = happyGoto action_266
+action_469 (37#) = happyGoto action_267
+action_469 (38#) = happyGoto action_268
+action_469 (39#) = happyGoto action_269
+action_469 (40#) = happyGoto action_270
+action_469 (41#) = happyGoto action_271
+action_469 (43#) = happyGoto action_272
+action_469 (44#) = happyGoto action_273
+action_469 (45#) = happyGoto action_188
+action_469 (46#) = happyGoto action_189
+action_469 (47#) = happyGoto action_190
+action_469 (48#) = happyGoto action_191
+action_469 (49#) = happyGoto action_192
+action_469 (50#) = happyGoto action_193
+action_469 (103#) = happyGoto action_505
+action_469 (114#) = happyGoto action_194
+action_469 x = happyTcHack x happyReduce_321
+
+action_470 (123#) = happyShift action_504
+action_470 (168#) = happyShift action_303
+action_470 (15#) = happyGoto action_496
+action_470 (16#) = happyGoto action_302
+action_470 x = happyTcHack x happyReduce_39
+
+action_471 (125#) = happyShift action_502
+action_471 (169#) = happyShift action_503
+action_471 x = happyTcHack x happyFail
+
+action_472 x = happyTcHack x happyReduce_312
+
+action_473 x = happyTcHack x happyReduce_314
+
+action_474 x = happyTcHack x happyReduce_315
+
+action_475 (146#) = happyShift action_501
+action_475 (176#) = happyShift action_86
+action_475 (114#) = happyGoto action_500
+action_475 x = happyTcHack x happyFail
+
+action_476 (146#) = happyShift action_499
+action_476 (176#) = happyShift action_86
+action_476 (114#) = happyGoto action_498
+action_476 x = happyTcHack x happyFail
+
+action_477 (123#) = happyShift action_497
+action_477 (168#) = happyShift action_303
+action_477 (15#) = happyGoto action_496
+action_477 (16#) = happyGoto action_302
+action_477 x = happyTcHack x happyReduce_39
+
+action_478 x = happyTcHack x happyReduce_27
+
+action_479 (176#) = happyShift action_495
+action_479 x = happyTcHack x happyFail
+
+action_480 (121#) = happyShift action_494
+action_480 x = happyTcHack x happyFail
+
+action_481 (124#) = happyShift action_493
+action_481 x = happyTcHack x happyFail
+
+action_482 (137#) = happyShift action_287
+action_482 x = happyTcHack x happyReduce_125
+
+action_483 (133#) = happyShift action_286
+action_483 x = happyTcHack x happyReduce_127
+
+action_484 (135#) = happyShift action_285
+action_484 x = happyTcHack x happyReduce_129
+
+action_485 (136#) = happyShift action_284
+action_485 x = happyTcHack x happyReduce_131
+
+action_486 (131#) = happyShift action_282
+action_486 (132#) = happyShift action_283
+action_486 (42#) = happyGoto action_281
+action_486 x = happyTcHack x happyReduce_133
+
+action_487 (164#) = happyShift action_277
+action_487 (165#) = happyShift action_278
+action_487 (166#) = happyShift action_279
+action_487 (167#) = happyShift action_280
+action_487 x = happyTcHack x happyReduce_135
+
+action_488 (138#) = happyShift action_276
+action_488 x = happyTcHack x happyReduce_141
+
+action_489 (138#) = happyShift action_276
+action_489 x = happyTcHack x happyReduce_142
+
+action_490 (138#) = happyShift action_276
+action_490 x = happyTcHack x happyReduce_140
+
+action_491 (138#) = happyShift action_276
+action_491 x = happyTcHack x happyReduce_139
+
+action_492 (180#) = happyShift action_384
+action_492 (182#) = happyShift action_385
+action_492 x = happyTcHack x happyReduce_144
+
+action_493 (120#) = happyShift action_195
+action_493 (141#) = happyShift action_196
+action_493 (142#) = happyShift action_197
+action_493 (170#) = happyShift action_198
+action_493 (173#) = happyShift action_199
+action_493 (174#) = happyShift action_200
+action_493 (176#) = happyShift action_86
+action_493 (180#) = happyShift action_201
+action_493 (182#) = happyShift action_202
+action_493 (36#) = happyGoto action_568
+action_493 (37#) = happyGoto action_267
+action_493 (38#) = happyGoto action_268
+action_493 (39#) = happyGoto action_269
+action_493 (40#) = happyGoto action_270
+action_493 (41#) = happyGoto action_271
+action_493 (43#) = happyGoto action_272
+action_493 (44#) = happyGoto action_273
+action_493 (45#) = happyGoto action_188
+action_493 (46#) = happyGoto action_189
+action_493 (47#) = happyGoto action_190
+action_493 (48#) = happyGoto action_191
+action_493 (49#) = happyGoto action_192
+action_493 (50#) = happyGoto action_193
+action_493 (114#) = happyGoto action_194
+action_493 x = happyTcHack x happyFail
+
+action_494 x = happyTcHack x happyReduce_348
+
+action_495 (121#) = happyShift action_566
+action_495 (125#) = happyShift action_567
+action_495 x = happyTcHack x happyFail
+
+action_496 x = happyTcHack x happyReduce_34
+
+action_497 x = happyTcHack x happyReduce_25
+
+action_498 x = happyTcHack x happyReduce_38
+
+action_499 x = happyTcHack x happyReduce_36
+
+action_500 x = happyTcHack x happyReduce_37
+
+action_501 x = happyTcHack x happyReduce_35
+
+action_502 (162#) = happyShift action_474
+action_502 (176#) = happyShift action_86
+action_502 (100#) = happyGoto action_565
+action_502 (114#) = happyGoto action_473
+action_502 x = happyTcHack x happyFail
+
+action_503 x = happyTcHack x happyReduce_40
+
+action_504 x = happyTcHack x happyReduce_26
+
+action_505 x = happyTcHack x happyReduce_319
+
+action_506 x = happyTcHack x happyReduce_325
+
+action_507 x = happyTcHack x happyReduce_286
+
+action_508 x = happyTcHack x happyReduce_293
+
+action_509 (121#) = happyShift action_564
+action_509 x = happyTcHack x happyFail
+
+action_510 x = happyTcHack x happyReduce_216
+
+action_511 x = happyTcHack x happyReduce_266
+
+action_512 (120#) = happyShift action_148
+action_512 (124#) = happyShift action_104
+action_512 (146#) = happyShift action_105
+action_512 (168#) = happyShift action_428
+action_512 (172#) = happyShift action_106
+action_512 (175#) = happyShift action_149
+action_512 (176#) = happyShift action_86
+action_512 (181#) = happyShift action_150
+action_512 (193#) = happyShift action_69
+action_512 (64#) = happyGoto action_563
+action_512 (65#) = happyGoto action_140
+action_512 (66#) = happyGoto action_141
+action_512 (67#) = happyGoto action_142
+action_512 (68#) = happyGoto action_143
+action_512 (69#) = happyGoto action_144
+action_512 (70#) = happyGoto action_145
+action_512 (71#) = happyGoto action_146
+action_512 (110#) = happyGoto action_147
+action_512 (111#) = happyGoto action_35
+action_512 (114#) = happyGoto action_102
+action_512 x = happyTcHack x happyReduce_274
+
+action_513 x = happyTcHack x happyReduce_277
+
+action_514 (120#) = happyShift action_195
+action_514 (141#) = happyShift action_196
+action_514 (142#) = happyShift action_197
+action_514 (170#) = happyShift action_198
+action_514 (173#) = happyShift action_199
+action_514 (174#) = happyShift action_200
+action_514 (176#) = happyShift action_86
+action_514 (180#) = happyShift action_201
+action_514 (182#) = happyShift action_202
+action_514 (34#) = happyGoto action_561
+action_514 (35#) = happyGoto action_265
+action_514 (36#) = happyGoto action_266
+action_514 (37#) = happyGoto action_267
+action_514 (38#) = happyGoto action_268
+action_514 (39#) = happyGoto action_269
+action_514 (40#) = happyGoto action_270
+action_514 (41#) = happyGoto action_271
+action_514 (43#) = happyGoto action_272
+action_514 (44#) = happyGoto action_273
+action_514 (45#) = happyGoto action_188
+action_514 (46#) = happyGoto action_189
+action_514 (47#) = happyGoto action_190
+action_514 (48#) = happyGoto action_191
+action_514 (49#) = happyGoto action_192
+action_514 (50#) = happyGoto action_193
+action_514 (84#) = happyGoto action_562
+action_514 (114#) = happyGoto action_194
+action_514 x = happyTcHack x happyFail
+
+action_515 (1#) = happyShift action_36
+action_515 (117#) = happyReduce_269
+action_515 (128#) = happyShift action_157
+action_515 (129#) = happyShift action_158
+action_515 (146#) = happyShift action_40
+action_515 (147#) = happyShift action_41
+action_515 (148#) = happyShift action_42
+action_515 (149#) = happyShift action_43
+action_515 (150#) = happyShift action_44
+action_515 (151#) = happyShift action_45
+action_515 (152#) = happyShift action_46
+action_515 (153#) = happyShift action_47
+action_515 (154#) = happyShift action_48
+action_515 (155#) = happyShift action_49
+action_515 (156#) = happyShift action_50
+action_515 (157#) = happyShift action_51
+action_515 (158#) = happyShift action_52
+action_515 (159#) = happyShift action_53
+action_515 (163#) = happyShift action_54
+action_515 (171#) = happyShift action_56
+action_515 (176#) = happyShift action_57
+action_515 (197#) = happyShift action_73
+action_515 (31#) = happyGoto action_18
+action_515 (32#) = happyGoto action_19
+action_515 (52#) = happyGoto action_559
+action_515 (54#) = happyGoto action_333
+action_515 (55#) = happyGoto action_334
+action_515 (59#) = happyGoto action_76
+action_515 (60#) = happyGoto action_25
+action_515 (61#) = happyGoto action_26
+action_515 (79#) = happyGoto action_560
+action_515 (86#) = happyGoto action_77
+action_515 x = happyTcHack x happyFail
+
+action_516 x = happyTcHack x happyReduce_212
+
+action_517 (120#) = happyShift action_148
+action_517 (124#) = happyShift action_104
+action_517 (146#) = happyShift action_105
+action_517 (172#) = happyShift action_106
+action_517 (175#) = happyShift action_149
+action_517 (176#) = happyShift action_86
+action_517 (181#) = happyShift action_150
+action_517 (193#) = happyShift action_69
+action_517 (64#) = happyGoto action_558
+action_517 (65#) = happyGoto action_140
+action_517 (66#) = happyGoto action_141
+action_517 (67#) = happyGoto action_142
+action_517 (68#) = happyGoto action_143
+action_517 (69#) = happyGoto action_144
+action_517 (70#) = happyGoto action_145
+action_517 (71#) = happyGoto action_146
+action_517 (110#) = happyGoto action_147
+action_517 (111#) = happyGoto action_35
+action_517 (114#) = happyGoto action_102
+action_517 x = happyTcHack x happyFail
+
+action_518 x = happyTcHack x happyReduce_254
+
+action_519 x = happyTcHack x happyReduce_23
+
+action_520 x = happyTcHack x happyReduce_165
+
+action_521 (169#) = happyShift action_557
+action_521 x = happyTcHack x happyFail
+
+action_522 x = happyTcHack x happyReduce_172
+
+action_523 x = happyTcHack x happyReduce_170
+
+action_524 (120#) = happyShift action_380
+action_524 (173#) = happyShift action_199
+action_524 (174#) = happyShift action_200
+action_524 (176#) = happyShift action_86
+action_524 (50#) = happyGoto action_556
+action_524 (114#) = happyGoto action_194
+action_524 x = happyTcHack x happyFail
+
+action_525 x = happyTcHack x happyReduce_330
+
+action_526 (120#) = happyShift action_530
+action_526 (124#) = happyShift action_104
+action_526 (146#) = happyShift action_105
+action_526 (172#) = happyShift action_106
+action_526 (175#) = happyShift action_149
+action_526 (176#) = happyShift action_86
+action_526 (181#) = happyShift action_150
+action_526 (193#) = happyShift action_69
+action_526 (65#) = happyGoto action_554
+action_526 (66#) = happyGoto action_214
+action_526 (67#) = happyGoto action_142
+action_526 (68#) = happyGoto action_215
+action_526 (69#) = happyGoto action_144
+action_526 (70#) = happyGoto action_145
+action_526 (71#) = happyGoto action_527
+action_526 (107#) = happyGoto action_555
+action_526 (108#) = happyGoto action_529
+action_526 (110#) = happyGoto action_147
+action_526 (111#) = happyGoto action_35
+action_526 (114#) = happyGoto action_102
+action_526 x = happyTcHack x happyFail
+
+action_527 (120#) = happyShift action_530
+action_527 (124#) = happyShift action_104
+action_527 (146#) = happyShift action_105
+action_527 (172#) = happyShift action_106
+action_527 (175#) = happyShift action_211
+action_527 (176#) = happyShift action_86
+action_527 (193#) = happyShift action_69
+action_527 (66#) = happyGoto action_209
+action_527 (67#) = happyGoto action_142
+action_527 (69#) = happyGoto action_144
+action_527 (70#) = happyGoto action_145
+action_527 (108#) = happyGoto action_553
+action_527 (110#) = happyGoto action_210
+action_527 (111#) = happyGoto action_35
+action_527 (114#) = happyGoto action_102
+action_527 x = happyTcHack x happyReduce_335
+
+action_528 x = happyTcHack x happyReduce_331
+
+action_529 (120#) = happyShift action_552
+action_529 x = happyTcHack x happyReduce_337
+
+action_530 (120#) = happyShift action_530
+action_530 (121#) = happyShift action_551
+action_530 (124#) = happyShift action_104
+action_530 (127#) = happyShift action_355
+action_530 (146#) = happyShift action_105
+action_530 (168#) = happyShift action_55
+action_530 (172#) = happyShift action_106
+action_530 (175#) = happyShift action_149
+action_530 (176#) = happyShift action_86
+action_530 (181#) = happyShift action_150
+action_530 (193#) = happyShift action_69
+action_530 (64#) = happyGoto action_208
+action_530 (65#) = happyGoto action_526
+action_530 (66#) = happyGoto action_141
+action_530 (67#) = happyGoto action_142
+action_530 (68#) = happyGoto action_143
+action_530 (69#) = happyGoto action_144
+action_530 (70#) = happyGoto action_145
+action_530 (71#) = happyGoto action_527
+action_530 (94#) = happyGoto action_351
+action_530 (95#) = happyGoto action_219
+action_530 (96#) = happyGoto action_220
+action_530 (105#) = happyGoto action_352
+action_530 (106#) = happyGoto action_549
+action_530 (107#) = happyGoto action_550
+action_530 (108#) = happyGoto action_529
+action_530 (110#) = happyGoto action_147
+action_530 (111#) = happyGoto action_35
+action_530 (114#) = happyGoto action_102
+action_530 x = happyTcHack x happyReduce_303
+
+action_531 x = happyTcHack x happyReduce_334
+
+action_532 x = happyTcHack x happyReduce_168
+
+action_533 x = happyTcHack x happyReduce_155
+
+action_534 (168#) = happyReduce_80
+action_534 x = happyTcHack x happyReduce_108
+
+action_535 (168#) = happyReduce_86
+action_535 x = happyTcHack x happyReduce_114
+
+action_536 (168#) = happyReduce_87
+action_536 x = happyTcHack x happyReduce_113
+
+action_537 x = happyTcHack x happyReduce_153
+
+action_538 (1#) = happyShift action_36
+action_538 (128#) = happyShift action_157
+action_538 (129#) = happyShift action_158
+action_538 (146#) = happyShift action_40
+action_538 (147#) = happyShift action_41
+action_538 (148#) = happyShift action_42
+action_538 (149#) = happyShift action_43
+action_538 (150#) = happyShift action_44
+action_538 (151#) = happyShift action_45
+action_538 (152#) = happyShift action_46
+action_538 (153#) = happyShift action_47
+action_538 (154#) = happyShift action_48
+action_538 (155#) = happyShift action_49
+action_538 (156#) = happyShift action_50
+action_538 (157#) = happyShift action_51
+action_538 (158#) = happyShift action_52
+action_538 (159#) = happyShift action_53
+action_538 (163#) = happyShift action_54
+action_538 (171#) = happyShift action_56
+action_538 (176#) = happyShift action_57
+action_538 (197#) = happyShift action_73
+action_538 (31#) = happyGoto action_18
+action_538 (32#) = happyGoto action_19
+action_538 (52#) = happyGoto action_548
+action_538 (54#) = happyGoto action_333
+action_538 (55#) = happyGoto action_334
+action_538 (59#) = happyGoto action_76
+action_538 (60#) = happyGoto action_25
+action_538 (61#) = happyGoto action_26
+action_538 (86#) = happyGoto action_77
+action_538 x = happyTcHack x happyFail
+
+action_539 (124#) = happyShift action_547
+action_539 x = happyTcHack x happyFail
+
+action_540 x = happyTcHack x happyReduce_30
+
+action_541 x = happyTcHack x happyReduce_58
+
+action_542 x = happyTcHack x happyReduce_54
+
+action_543 x = happyTcHack x happyReduce_57
+
+action_544 x = happyTcHack x happyReduce_53
+
+action_545 x = happyTcHack x happyReduce_56
+
+action_546 x = happyTcHack x happyReduce_55
+
+action_547 (91#) = happyGoto action_583
+action_547 x = happyTcHack x happyReduce_298
+
+action_548 (120#) = happyShift action_148
+action_548 (124#) = happyShift action_104
+action_548 (146#) = happyShift action_105
+action_548 (168#) = happyShift action_428
+action_548 (172#) = happyShift action_106
+action_548 (175#) = happyShift action_149
+action_548 (176#) = happyShift action_86
+action_548 (181#) = happyShift action_150
+action_548 (193#) = happyShift action_69
+action_548 (64#) = happyGoto action_582
+action_548 (65#) = happyGoto action_140
+action_548 (66#) = happyGoto action_141
+action_548 (67#) = happyGoto action_142
+action_548 (68#) = happyGoto action_143
+action_548 (69#) = happyGoto action_144
+action_548 (70#) = happyGoto action_145
+action_548 (71#) = happyGoto action_146
+action_548 (110#) = happyGoto action_147
+action_548 (111#) = happyGoto action_35
+action_548 (114#) = happyGoto action_102
+action_548 x = happyTcHack x happyFail
+
+action_549 (121#) = happyShift action_581
+action_549 (125#) = happyShift action_421
+action_549 x = happyTcHack x happyFail
+
+action_550 (121#) = happyShift action_580
+action_550 x = happyTcHack x happyFail
+
+action_551 x = happyTcHack x happyReduce_340
+
+action_552 (121#) = happyShift action_579
+action_552 (127#) = happyShift action_355
+action_552 (168#) = happyShift action_55
+action_552 (94#) = happyGoto action_351
+action_552 (95#) = happyGoto action_219
+action_552 (96#) = happyGoto action_220
+action_552 (105#) = happyGoto action_352
+action_552 (106#) = happyGoto action_578
+action_552 x = happyTcHack x happyReduce_303
+
+action_553 (120#) = happyShift action_552
+action_553 x = happyTcHack x happyReduce_338
+
+action_554 (120#) = happyShift action_577
+action_554 (175#) = happyShift action_149
+action_554 (181#) = happyShift action_150
+action_554 (193#) = happyShift action_69
+action_554 (65#) = happyGoto action_554
+action_554 (71#) = happyGoto action_576
+action_554 (107#) = happyGoto action_555
+action_554 (108#) = happyGoto action_529
+action_554 (110#) = happyGoto action_147
+action_554 (111#) = happyGoto action_35
+action_554 x = happyTcHack x happyFail
+
+action_555 x = happyTcHack x happyReduce_336
+
+action_556 (169#) = happyShift action_575
+action_556 x = happyTcHack x happyFail
+
+action_557 x = happyTcHack x happyReduce_173
+
+action_558 x = happyTcHack x happyReduce_221
+
+action_559 (120#) = happyShift action_148
+action_559 (124#) = happyShift action_104
+action_559 (146#) = happyShift action_105
+action_559 (168#) = happyShift action_428
+action_559 (172#) = happyShift action_106
+action_559 (175#) = happyShift action_149
+action_559 (176#) = happyShift action_86
+action_559 (181#) = happyShift action_150
+action_559 (193#) = happyShift action_69
+action_559 (64#) = happyGoto action_574
+action_559 (65#) = happyGoto action_140
+action_559 (66#) = happyGoto action_141
+action_559 (67#) = happyGoto action_142
+action_559 (68#) = happyGoto action_143
+action_559 (69#) = happyGoto action_144
+action_559 (70#) = happyGoto action_145
+action_559 (71#) = happyGoto action_146
+action_559 (110#) = happyGoto action_147
+action_559 (111#) = happyGoto action_35
+action_559 (114#) = happyGoto action_102
+action_559 x = happyTcHack x happyReduce_271
+
+action_560 x = happyTcHack x happyReduce_268
+
+action_561 x = happyTcHack x happyReduce_281
+
+action_562 (121#) = happyShift action_572
+action_562 (125#) = happyShift action_573
+action_562 x = happyTcHack x happyFail
+
+action_563 x = happyTcHack x happyReduce_273
+
+action_564 (176#) = happyShift action_86
+action_564 (75#) = happyGoto action_570
+action_564 (114#) = happyGoto action_571
+action_564 x = happyTcHack x happyReduce_257
+
+action_565 x = happyTcHack x happyReduce_313
+
+action_566 x = happyTcHack x happyReduce_351
+
+action_567 (120#) = happyShift action_195
+action_567 (141#) = happyShift action_196
+action_567 (142#) = happyShift action_197
+action_567 (170#) = happyShift action_198
+action_567 (173#) = happyShift action_199
+action_567 (174#) = happyShift action_200
+action_567 (176#) = happyShift action_86
+action_567 (180#) = happyShift action_201
+action_567 (182#) = happyShift action_202
+action_567 (34#) = happyGoto action_561
+action_567 (35#) = happyGoto action_265
+action_567 (36#) = happyGoto action_266
+action_567 (37#) = happyGoto action_267
+action_567 (38#) = happyGoto action_268
+action_567 (39#) = happyGoto action_269
+action_567 (40#) = happyGoto action_270
+action_567 (41#) = happyGoto action_271
+action_567 (43#) = happyGoto action_272
+action_567 (44#) = happyGoto action_273
+action_567 (45#) = happyGoto action_188
+action_567 (46#) = happyGoto action_189
+action_567 (47#) = happyGoto action_190
+action_567 (48#) = happyGoto action_191
+action_567 (49#) = happyGoto action_192
+action_567 (50#) = happyGoto action_193
+action_567 (84#) = happyGoto action_569
+action_567 (114#) = happyGoto action_194
+action_567 x = happyTcHack x happyFail
+
+action_568 (134#) = happyShift action_288
+action_568 x = happyTcHack x happyReduce_123
+
+action_569 (121#) = happyShift action_591
+action_569 (125#) = happyShift action_573
+action_569 x = happyTcHack x happyFail
+
+action_570 (122#) = happyShift action_590
+action_570 x = happyTcHack x happyFail
+
+action_571 x = happyTcHack x happyReduce_258
+
+action_572 x = happyTcHack x happyReduce_279
+
+action_573 (120#) = happyShift action_195
+action_573 (141#) = happyShift action_196
+action_573 (142#) = happyShift action_197
+action_573 (170#) = happyShift action_198
+action_573 (173#) = happyShift action_199
+action_573 (174#) = happyShift action_200
+action_573 (176#) = happyShift action_86
+action_573 (180#) = happyShift action_201
+action_573 (182#) = happyShift action_202
+action_573 (34#) = happyGoto action_589
+action_573 (35#) = happyGoto action_265
+action_573 (36#) = happyGoto action_266
+action_573 (37#) = happyGoto action_267
+action_573 (38#) = happyGoto action_268
+action_573 (39#) = happyGoto action_269
+action_573 (40#) = happyGoto action_270
+action_573 (41#) = happyGoto action_271
+action_573 (43#) = happyGoto action_272
+action_573 (44#) = happyGoto action_273
+action_573 (45#) = happyGoto action_188
+action_573 (46#) = happyGoto action_189
+action_573 (47#) = happyGoto action_190
+action_573 (48#) = happyGoto action_191
+action_573 (49#) = happyGoto action_192
+action_573 (50#) = happyGoto action_193
+action_573 (114#) = happyGoto action_194
+action_573 x = happyTcHack x happyFail
+
+action_574 x = happyTcHack x happyReduce_270
+
+action_575 x = happyTcHack x happyReduce_244
+
+action_576 (120#) = happyShift action_577
+action_576 (108#) = happyGoto action_553
+action_576 x = happyTcHack x happyReduce_335
+
+action_577 (120#) = happyShift action_577
+action_577 (121#) = happyShift action_551
+action_577 (127#) = happyShift action_355
+action_577 (168#) = happyShift action_55
+action_577 (175#) = happyShift action_149
+action_577 (181#) = happyShift action_150
+action_577 (193#) = happyShift action_69
+action_577 (65#) = happyGoto action_554
+action_577 (71#) = happyGoto action_576
+action_577 (94#) = happyGoto action_351
+action_577 (95#) = happyGoto action_219
+action_577 (96#) = happyGoto action_220
+action_577 (105#) = happyGoto action_352
+action_577 (106#) = happyGoto action_549
+action_577 (107#) = happyGoto action_550
+action_577 (108#) = happyGoto action_529
+action_577 (110#) = happyGoto action_147
+action_577 (111#) = happyGoto action_35
+action_577 x = happyTcHack x happyReduce_303
+
+action_578 (121#) = happyShift action_588
+action_578 (125#) = happyShift action_421
+action_578 x = happyTcHack x happyFail
+
+action_579 x = happyTcHack x happyReduce_342
+
+action_580 x = happyTcHack x happyReduce_339
+
+action_581 x = happyTcHack x happyReduce_341
+
+action_582 (117#) = happyShift action_587
+action_582 x = happyTcHack x happyFail
+
+action_583 (123#) = happyShift action_586
+action_583 (168#) = happyShift action_55
+action_583 (92#) = happyGoto action_584
+action_583 (94#) = happyGoto action_585
+action_583 (95#) = happyGoto action_219
+action_583 (96#) = happyGoto action_220
+action_583 x = happyTcHack x happyReduce_303
+
+action_584 (117#) = happyShift action_594
+action_584 x = happyTcHack x happyFail
+
+action_585 (1#) = happyShift action_36
+action_585 (146#) = happyShift action_40
+action_585 (147#) = happyShift action_41
+action_585 (148#) = happyShift action_42
+action_585 (149#) = happyShift action_43
+action_585 (150#) = happyShift action_44
+action_585 (151#) = happyShift action_45
+action_585 (152#) = happyShift action_46
+action_585 (153#) = happyShift action_47
+action_585 (154#) = happyShift action_48
+action_585 (155#) = happyShift action_49
+action_585 (156#) = happyShift action_50
+action_585 (157#) = happyShift action_51
+action_585 (158#) = happyShift action_52
+action_585 (159#) = happyShift action_53
+action_585 (163#) = happyShift action_54
+action_585 (171#) = happyShift action_56
+action_585 (176#) = happyShift action_57
+action_585 (183#) = happyShift action_61
+action_585 (184#) = happyShift action_62
+action_585 (197#) = happyShift action_73
+action_585 (31#) = happyGoto action_18
+action_585 (32#) = happyGoto action_19
+action_585 (53#) = happyGoto action_21
+action_585 (55#) = happyGoto action_22
+action_585 (59#) = happyGoto action_76
+action_585 (60#) = happyGoto action_25
+action_585 (61#) = happyGoto action_26
+action_585 (86#) = happyGoto action_77
+action_585 (89#) = happyGoto action_28
+action_585 (90#) = happyGoto action_29
+action_585 (104#) = happyGoto action_593
+action_585 x = happyTcHack x happyFail
+
+action_586 x = happyTcHack x happyReduce_29
+
+action_587 x = happyTcHack x happyReduce_32
+
+action_588 x = happyTcHack x happyReduce_343
+
+action_589 x = happyTcHack x happyReduce_282
+
+action_590 (161#) = happyShift action_327
+action_590 (162#) = happyShift action_328
+action_590 (168#) = happyShift action_450
+action_590 (77#) = happyGoto action_592
+action_590 (78#) = happyGoto action_324
+action_590 (81#) = happyGoto action_325
+action_590 (82#) = happyGoto action_326
+action_590 x = happyTcHack x happyFail
+
+action_591 x = happyTcHack x happyReduce_352
+
+action_592 (123#) = happyShift action_596
+action_592 (161#) = happyShift action_327
+action_592 (162#) = happyShift action_328
+action_592 (168#) = happyShift action_450
+action_592 (78#) = happyGoto action_449
+action_592 (81#) = happyGoto action_325
+action_592 (82#) = happyGoto action_326
+action_592 x = happyTcHack x happyFail
+
+action_593 (120#) = happyShift action_148
+action_593 (124#) = happyShift action_104
+action_593 (146#) = happyShift action_105
+action_593 (172#) = happyShift action_106
+action_593 (175#) = happyShift action_149
+action_593 (176#) = happyShift action_86
+action_593 (181#) = happyShift action_150
+action_593 (193#) = happyShift action_69
+action_593 (64#) = happyGoto action_595
+action_593 (65#) = happyGoto action_140
+action_593 (66#) = happyGoto action_141
+action_593 (67#) = happyGoto action_142
+action_593 (68#) = happyGoto action_143
+action_593 (69#) = happyGoto action_144
+action_593 (70#) = happyGoto action_145
+action_593 (71#) = happyGoto action_146
+action_593 (110#) = happyGoto action_147
+action_593 (111#) = happyGoto action_35
+action_593 (114#) = happyGoto action_102
+action_593 x = happyTcHack x happyFail
+
+action_594 x = happyTcHack x happyReduce_299
+
+action_595 (193#) = happyShift action_69
+action_595 (109#) = happyGoto action_597
+action_595 (110#) = happyGoto action_34
+action_595 (111#) = happyGoto action_35
+action_595 x = happyTcHack x happyReduce_344
+
+action_596 x = happyTcHack x happyReduce_215
+
+action_597 x = happyTcHack x happyReduce_300
+
+happyReduce_1 = happySpecReduce_1 4# happyReduction_1
+happyReduction_1 (HappyAbsSyn5  happy_var_1)
+	 =  HappyAbsSyn4
+		 (Left  (reverse happy_var_1)
+	)
+happyReduction_1 _  = notHappyAtAll 
+
+happyReduce_2 = happySpecReduce_2 4# happyReduction_2
+happyReduction_2 (HappyAbsSyn6  happy_var_2)
+	_
+	 =  HappyAbsSyn4
+		 (Right (reverse happy_var_2)
+	)
+happyReduction_2 _ _  = notHappyAtAll 
+
+happyReduce_3 = happySpecReduce_0 5# happyReduction_3
+happyReduction_3  =  HappyAbsSyn5
+		 ([]
+	)
+
+happyReduce_4 = happySpecReduce_2 5# happyReduction_4
+happyReduction_4 (HappyAbsSyn9  happy_var_2)
+	(HappyAbsSyn5  happy_var_1)
+	 =  HappyAbsSyn5
+		 (happy_var_2 : happy_var_1
+	)
+happyReduction_4 _ _  = notHappyAtAll 
+
+happyReduce_5 = happySpecReduce_0 6# happyReduction_5
+happyReduction_5  =  HappyAbsSyn6
+		 ([]
+	)
+
+happyReduce_6 = happySpecReduce_2 6# happyReduction_6
+happyReduction_6 (HappyAbsSyn7  happy_var_2)
+	(HappyAbsSyn6  happy_var_1)
+	 =  HappyAbsSyn6
+		 (happy_var_2 : happy_var_1
+	)
+happyReduction_6 _ _  = notHappyAtAll 
+
+happyReduce_7 = happySpecReduce_3 7# happyReduction_7
+happyReduction_7 (HappyAbsSyn16  happy_var_3)
+	_
+	(HappyAbsSyn8  happy_var_1)
+	 =  HappyAbsSyn7
+		 ((happy_var_1, True, happy_var_3)
+	)
+happyReduction_7 _ _ _  = notHappyAtAll 
+
+happyReduce_8 = happySpecReduce_3 7# happyReduction_8
+happyReduction_8 (HappyAbsSyn16  happy_var_3)
+	_
+	(HappyAbsSyn8  happy_var_1)
+	 =  HappyAbsSyn7
+		 ((happy_var_1, False, happy_var_3)
+	)
+happyReduction_8 _ _ _  = notHappyAtAll 
+
+happyReduce_9 = happySpecReduce_1 8# happyReduction_9
+happyReduction_9 (HappyTerminal (T_id happy_var_1))
+	 =  HappyAbsSyn8
+		 (happy_var_1
+	)
+happyReduction_9 _  = notHappyAtAll 
+
+happyReduce_10 = happySpecReduce_1 8# happyReduction_10
+happyReduction_10 (HappyTerminal (T_type happy_var_1))
+	 =  HappyAbsSyn8
+		 (happy_var_1
+	)
+happyReduction_10 _  = notHappyAtAll 
+
+happyReduce_11 = happySpecReduce_2 9# happyReduction_11
+happyReduction_11 _
+	(HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_11 _ _  = notHappyAtAll 
+
+happyReduce_12 = happyMonadReduce 3# 9# happyReduction_12
+happyReduction_12 (_ `HappyStk`
+	(HappyAbsSyn18  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = happyThen ( let (Id i) = happy_var_2 in addIfaceTypedef i >>= \ v -> return (Forward v)
+	) (\r -> happyReturn (HappyAbsSyn9 r))
+
+happyReduce_13 = happySpecReduce_2 9# happyReduction_13
+happyReduction_13 _
+	(HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_13 _ _  = notHappyAtAll 
+
+happyReduce_14 = happySpecReduce_2 9# happyReduction_14
+happyReduction_14 _
+	(HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_14 _ _  = notHappyAtAll 
+
+happyReduce_15 = happySpecReduce_2 9# happyReduction_15
+happyReduction_15 _
+	(HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_15 _ _  = notHappyAtAll 
+
+happyReduce_16 = happySpecReduce_1 9# happyReduction_16
+happyReduction_16 (HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_16 _  = notHappyAtAll 
+
+happyReduce_17 = happySpecReduce_2 9# happyReduction_17
+happyReduction_17 _
+	(HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_17 _ _  = notHappyAtAll 
+
+happyReduce_18 = happySpecReduce_1 9# happyReduction_18
+happyReduction_18 (HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_18 _  = notHappyAtAll 
+
+happyReduce_19 = happySpecReduce_2 10# happyReduction_19
+happyReduction_19 (HappyAbsSyn9  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn9
+		 (Attributed happy_var_1 happy_var_2
+	)
+happyReduction_19 _ _  = notHappyAtAll 
+
+happyReduce_20 = happySpecReduce_1 10# happyReduction_20
+happyReduction_20 (HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_20 _  = notHappyAtAll 
+
+happyReduce_21 = happySpecReduce_1 11# happyReduction_21
+happyReduction_21 (HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_21 _  = notHappyAtAll 
+
+happyReduce_22 = happySpecReduce_2 11# happyReduction_22
+happyReduction_22 (HappyAbsSyn18  happy_var_2)
+	_
+	 =  HappyAbsSyn9
+		 (Forward happy_var_2
+	)
+happyReduction_22 _ _  = notHappyAtAll 
+
+happyReduce_23 = happyReduce 6# 11# happyReduction_23
+happyReduction_23 (_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn5  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn9
+		 (Module happy_var_2 (reverse happy_var_4)
+	) `HappyStk` happyRest
+
+happyReduce_24 = happySpecReduce_1 11# happyReduction_24
+happyReduction_24 (HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_24 _  = notHappyAtAll 
+
+happyReduce_25 = happyMonadReduce 6# 11# happyReduction_25
+happyReduction_25 (_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn14  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = happyThen ( let (Id i) = happy_var_2 in addIfaceTypedef i >>= \ v -> return (CoClass v (reverse happy_var_4))
+	) (\r -> happyReturn (HappyAbsSyn9 r))
+
+happyReduce_26 = happyReduce 6# 11# happyReduction_26
+happyReduction_26 (_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn14  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyTerminal (T_type happy_var_2)) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn9
+		 (CoClass (Id happy_var_2) (reverse happy_var_4)
+	) `HappyStk` happyRest
+
+happyReduce_27 = happyReduce 5# 11# happyReduction_27
+happyReduction_27 (_ `HappyStk`
+	(HappyAbsSyn5  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn9
+		 (Library happy_var_2 (reverse happy_var_4)
+	) `HappyStk` happyRest
+
+happyReduce_28 = happySpecReduce_1 11# happyReduction_28
+happyReduction_28 (HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_28 _  = notHappyAtAll 
+
+happyReduce_29 = happyMonadReduce 9# 12# happyReduction_29
+happyReduction_29 (_ `HappyStk`
+	(HappyAbsSyn5  happy_var_8) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn13  happy_var_5) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_1) `HappyStk`
+	happyRest)
+	 = happyThen ( let (Id i) = happy_var_1 in addIfaceTypedef i >>= \ v -> return (DispInterface v happy_var_5 (reverse happy_var_8))
+	) (\r -> happyReturn (HappyAbsSyn9 r))
+
+happyReduce_30 = happyMonadReduce 6# 12# happyReduction_30
+happyReduction_30 (_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_1) `HappyStk`
+	happyRest)
+	 = happyThen ( let (Id i) = happy_var_1 in addIfaceTypedef i >>= \ v -> return (DispInterfaceDecl v happy_var_4)
+	) (\r -> happyReturn (HappyAbsSyn9 r))
+
+happyReduce_31 = happySpecReduce_0 13# happyReduction_31
+happyReduction_31  =  HappyAbsSyn13
+		 ([]
+	)
+
+happyReduce_32 = happyReduce 5# 13# happyReduction_32
+happyReduction_32 (_ `HappyStk`
+	(HappyAbsSyn18  happy_var_4) `HappyStk`
+	(HappyAbsSyn30  happy_var_3) `HappyStk`
+	(HappyAbsSyn16  happy_var_2) `HappyStk`
+	(HappyAbsSyn13  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn13
+		 ((happy_var_2,happy_var_3,happy_var_4):happy_var_1
+	) `HappyStk` happyRest
+
+happyReduce_33 = happySpecReduce_1 14# happyReduction_33
+happyReduction_33 (HappyAbsSyn15  happy_var_1)
+	 =  HappyAbsSyn14
+		 ([happy_var_1]
+	)
+happyReduction_33 _  = notHappyAtAll 
+
+happyReduce_34 = happySpecReduce_3 14# happyReduction_34
+happyReduction_34 (HappyAbsSyn15  happy_var_3)
+	_
+	(HappyAbsSyn14  happy_var_1)
+	 =  HappyAbsSyn14
+		 (happy_var_3 : happy_var_1
+	)
+happyReduction_34 _ _ _  = notHappyAtAll 
+
+happyReduce_35 = happySpecReduce_3 15# happyReduction_35
+happyReduction_35 (HappyTerminal (T_type happy_var_3))
+	_
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn15
+		 ((True,  Id happy_var_3, happy_var_1)
+	)
+happyReduction_35 _ _ _  = notHappyAtAll 
+
+happyReduce_36 = happySpecReduce_3 15# happyReduction_36
+happyReduction_36 (HappyTerminal (T_type happy_var_3))
+	_
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn15
+		 ((False, Id happy_var_3, happy_var_1)
+	)
+happyReduction_36 _ _ _  = notHappyAtAll 
+
+happyReduce_37 = happySpecReduce_3 15# happyReduction_37
+happyReduction_37 (HappyAbsSyn18  happy_var_3)
+	_
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn15
+		 ((True,  happy_var_3, happy_var_1)
+	)
+happyReduction_37 _ _ _  = notHappyAtAll 
+
+happyReduce_38 = happySpecReduce_3 15# happyReduction_38
+happyReduction_38 (HappyAbsSyn18  happy_var_3)
+	_
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn15
+		 ((False, happy_var_3, happy_var_1)
+	)
+happyReduction_38 _ _ _  = notHappyAtAll 
+
+happyReduce_39 = happySpecReduce_0 16# happyReduction_39
+happyReduction_39  =  HappyAbsSyn16
+		 ([]
+	)
+
+happyReduce_40 = happySpecReduce_3 16# happyReduction_40
+happyReduction_40 _
+	(HappyAbsSyn16  happy_var_2)
+	_
+	 =  HappyAbsSyn16
+		 (happy_var_2
+	)
+happyReduction_40 _ _ _  = notHappyAtAll 
+
+happyReduce_41 = happySpecReduce_1 17# happyReduction_41
+happyReduction_41 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn9
+		 (Forward happy_var_1
+	)
+happyReduction_41 _  = notHappyAtAll 
+
+happyReduce_42 = happyReduce 5# 17# happyReduction_42
+happyReduction_42 (_ `HappyStk`
+	(HappyAbsSyn5  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn25  happy_var_2) `HappyStk`
+	(HappyAbsSyn18  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn9
+		 (Interface happy_var_1 happy_var_2 (reverse happy_var_4)
+	) `HappyStk` happyRest
+
+happyReduce_43 = happyMonadReduce 2# 18# happyReduction_43
+happyReduction_43 ((HappyAbsSyn18  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = happyThen ( let (Id i) = happy_var_2 in addIfaceTypedef i >>= return
+	) (\r -> happyReturn (HappyAbsSyn18 r))
+
+happyReduce_44 = happySpecReduce_2 18# happyReduction_44
+happyReduction_44 (HappyTerminal (T_type happy_var_2))
+	_
+	 =  HappyAbsSyn18
+		 ((Id happy_var_2)
+	)
+happyReduction_44 _ _  = notHappyAtAll 
+
+happyReduce_45 = happySpecReduce_2 18# happyReduction_45
+happyReduction_45 _
+	_
+	 =  HappyAbsSyn18
+		 ((Id "Object")
+	)
+
+happyReduce_46 = happyMonadReduce 2# 19# happyReduction_46
+happyReduction_46 ((HappyAbsSyn18  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = happyThen ( let (Id i) = happy_var_2 in addIfaceTypedef i >>= return
+	) (\r -> happyReturn (HappyAbsSyn18 r))
+
+happyReduce_47 = happySpecReduce_2 19# happyReduction_47
+happyReduction_47 (HappyTerminal (T_type happy_var_2))
+	_
+	 =  HappyAbsSyn18
+		 ((Id happy_var_2)
+	)
+happyReduction_47 _ _  = notHappyAtAll 
+
+happyReduce_48 = happyReduce 4# 20# happyReduction_48
+happyReduction_48 (_ `HappyStk`
+	(HappyTerminal (T_string_lit happy_var_3)) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn9
+		 (CppQuote happy_var_3
+	) `HappyStk` happyRest
+
+happyReduce_49 = happyReduce 4# 21# happyReduction_49
+happyReduction_49 (_ `HappyStk`
+	(HappyTerminal (T_string_lit happy_var_3)) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn9
+		 (HsQuote happy_var_3
+	) `HappyStk` happyRest
+
+happyReduce_50 = happySpecReduce_1 21# happyReduction_50
+happyReduction_50 (HappyTerminal (T_include happy_var_1))
+	 =  HappyAbsSyn9
+		 (CInclude happy_var_1
+	)
+happyReduction_50 _  = notHappyAtAll 
+
+happyReduce_51 = happySpecReduce_0 22# happyReduction_51
+happyReduction_51  =  HappyAbsSyn5
+		 ([]
+	)
+
+happyReduce_52 = happySpecReduce_2 22# happyReduction_52
+happyReduction_52 (HappyAbsSyn9  happy_var_2)
+	(HappyAbsSyn5  happy_var_1)
+	 =  HappyAbsSyn5
+		 (happy_var_2 : happy_var_1
+	)
+happyReduction_52 _ _  = notHappyAtAll 
+
+happyReduce_53 = happySpecReduce_2 23# happyReduction_53
+happyReduction_53 _
+	(HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_53 _ _  = notHappyAtAll 
+
+happyReduce_54 = happySpecReduce_2 23# happyReduction_54
+happyReduction_54 _
+	(HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_54 _ _  = notHappyAtAll 
+
+happyReduce_55 = happySpecReduce_2 23# happyReduction_55
+happyReduction_55 _
+	(HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_55 _ _  = notHappyAtAll 
+
+happyReduce_56 = happySpecReduce_2 23# happyReduction_56
+happyReduction_56 _
+	(HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_56 _ _  = notHappyAtAll 
+
+happyReduce_57 = happySpecReduce_2 23# happyReduction_57
+happyReduction_57 _
+	(HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_57 _ _  = notHappyAtAll 
+
+happyReduce_58 = happySpecReduce_2 24# happyReduction_58
+happyReduction_58 (HappyAbsSyn9  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn9
+		 (Attributed happy_var_1 happy_var_2
+	)
+happyReduction_58 _ _  = notHappyAtAll 
+
+happyReduce_59 = happySpecReduce_1 24# happyReduction_59
+happyReduction_59 (HappyAbsSyn9  happy_var_1)
+	 =  HappyAbsSyn9
+		 (happy_var_1
+	)
+happyReduction_59 _  = notHappyAtAll 
+
+happyReduce_60 = happySpecReduce_0 25# happyReduction_60
+happyReduction_60  =  HappyAbsSyn25
+		 ([]
+	)
+
+happyReduce_61 = happySpecReduce_2 25# happyReduction_61
+happyReduction_61 (HappyTerminal (T_type happy_var_2))
+	_
+	 =  HappyAbsSyn25
+		 ([ happy_var_2 ]
+	)
+happyReduction_61 _ _  = notHappyAtAll 
+
+happyReduce_62 = happySpecReduce_2 25# happyReduction_62
+happyReduction_62 (HappyAbsSyn18  happy_var_2)
+	_
+	 =  HappyAbsSyn25
+		 (let (Id i) = happy_var_2 in [ i ]
+	)
+happyReduction_62 _ _  = notHappyAtAll 
+
+happyReduce_63 = happyMonadReduce 2# 26# happyReduction_63
+happyReduction_63 ((HappyAbsSyn29  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = happyThen ( slurpImports (parseIDL >>= \ (Left y) -> return y) happy_var_2
+	) (\r -> happyReturn (HappyAbsSyn9 r))
+
+happyReduce_64 = happyMonadReduce 4# 26# happyReduction_64
+happyReduction_64 (_ `HappyStk`
+	(HappyTerminal (T_string_lit happy_var_3)) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = happyThen ( handleImportLib (parseIDL >>= \ (Left y) -> return y) happy_var_3
+	) (\r -> happyReturn (HappyAbsSyn9 r))
+
+happyReduce_65 = happySpecReduce_1 27# happyReduction_65
+happyReduction_65 (HappyTerminal (T_pragma happy_var_1))
+	 =  HappyAbsSyn9
+		 (Pragma happy_var_1
+	)
+happyReduction_65 _  = notHappyAtAll 
+
+happyReduce_66 = happySpecReduce_1 27# happyReduction_66
+happyReduction_66 (HappyTerminal (T_include_start happy_var_1))
+	 =  HappyAbsSyn9
+		 (IncludeStart happy_var_1
+	)
+happyReduction_66 _  = notHappyAtAll 
+
+happyReduce_67 = happySpecReduce_1 27# happyReduction_67
+happyReduction_67 _
+	 =  HappyAbsSyn9
+		 (IncludeEnd
+	)
+
+happyReduce_68 = happySpecReduce_3 28# happyReduction_68
+happyReduction_68 (HappyAbsSyn34  happy_var_3)
+	(HappyTerminal (T_id happy_var_2))
+	_
+	 =  HappyAbsSyn9
+		 (Constant (Id happy_var_2) [] (exprType (TyInteger Natural) happy_var_3) happy_var_3
+	)
+happyReduction_68 _ _ _  = notHappyAtAll 
+
+happyReduce_69 = happySpecReduce_1 29# happyReduction_69
+happyReduction_69 (HappyTerminal (T_string_lit happy_var_1))
+	 =  HappyAbsSyn29
+		 ([ happy_var_1 ]
+	)
+happyReduction_69 _  = notHappyAtAll 
+
+happyReduce_70 = happySpecReduce_3 29# happyReduction_70
+happyReduction_70 (HappyAbsSyn29  happy_var_3)
+	_
+	(HappyTerminal (T_string_lit happy_var_1))
+	 =  HappyAbsSyn29
+		 ((happy_var_1 : happy_var_3)
+	)
+happyReduction_70 _ _ _  = notHappyAtAll 
+
+happyReduce_71 = happySpecReduce_1 30# happyReduction_71
+happyReduction_71 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_71 _  = notHappyAtAll 
+
+happyReduce_72 = happySpecReduce_1 30# happyReduction_72
+happyReduction_72 _
+	 =  HappyAbsSyn30
+		 (TyChar
+	)
+
+happyReduce_73 = happySpecReduce_1 30# happyReduction_73
+happyReduction_73 _
+	 =  HappyAbsSyn30
+		 (TyWChar
+	)
+
+happyReduce_74 = happySpecReduce_1 30# happyReduction_74
+happyReduction_74 (HappyTerminal (T_float happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyFloat happy_var_1
+	)
+happyReduction_74 _  = notHappyAtAll 
+
+happyReduce_75 = happySpecReduce_1 30# happyReduction_75
+happyReduction_75 _
+	 =  HappyAbsSyn30
+		 (TyVoid
+	)
+
+happyReduce_76 = happySpecReduce_2 30# happyReduction_76
+happyReduction_76 _
+	_
+	 =  HappyAbsSyn30
+		 (TyPointer TyVoid
+	)
+
+happyReduce_77 = happySpecReduce_2 30# happyReduction_77
+happyReduction_77 _
+	_
+	 =  HappyAbsSyn30
+		 (TyString Nothing
+	)
+
+happyReduce_78 = happySpecReduce_2 30# happyReduction_78
+happyReduction_78 _
+	_
+	 =  HappyAbsSyn30
+		 (TyWString Nothing
+	)
+
+happyReduce_79 = happySpecReduce_1 30# happyReduction_79
+happyReduction_79 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_79 _  = notHappyAtAll 
+
+happyReduce_80 = happySpecReduce_3 30# happyReduction_80
+happyReduction_80 _
+	_
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyArray happy_var_1 []
+	)
+happyReduction_80 _ _ _  = notHappyAtAll 
+
+happyReduce_81 = happySpecReduce_1 30# happyReduction_81
+happyReduction_81 _
+	 =  HappyAbsSyn30
+		 (TySigned True
+	)
+
+happyReduce_82 = happySpecReduce_1 30# happyReduction_82
+happyReduction_82 _
+	 =  HappyAbsSyn30
+		 (TySigned False
+	)
+
+happyReduce_83 = happySpecReduce_2 30# happyReduction_83
+happyReduction_83 (HappyAbsSyn30  happy_var_2)
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned False) happy_var_2
+	)
+happyReduction_83 _ _  = notHappyAtAll 
+
+happyReduce_84 = happySpecReduce_2 30# happyReduction_84
+happyReduction_84 (HappyAbsSyn30  happy_var_2)
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned True)  happy_var_2
+	)
+happyReduction_84 _ _  = notHappyAtAll 
+
+happyReduce_85 = happySpecReduce_2 30# happyReduction_85
+happyReduction_85 _
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned False) TyChar
+	)
+
+happyReduce_86 = happySpecReduce_3 30# happyReduction_86
+happyReduction_86 _
+	_
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned True)  happy_var_1
+	)
+happyReduction_86 _ _ _  = notHappyAtAll 
+
+happyReduce_87 = happySpecReduce_3 30# happyReduction_87
+happyReduction_87 _
+	_
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned False) happy_var_1
+	)
+happyReduction_87 _ _ _  = notHappyAtAll 
+
+happyReduce_88 = happySpecReduce_2 30# happyReduction_88
+happyReduction_88 _
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned True)  TyChar
+	)
+
+happyReduce_89 = happySpecReduce_1 30# happyReduction_89
+happyReduction_89 (HappyTerminal (T_id happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_89 _  = notHappyAtAll 
+
+happyReduce_90 = happySpecReduce_1 30# happyReduction_90
+happyReduction_90 (HappyTerminal (T_type happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_90 _  = notHappyAtAll 
+
+happyReduce_91 = happySpecReduce_2 30# happyReduction_91
+happyReduction_91 _
+	(HappyTerminal (T_type happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyPointer (TyName happy_var_1 Nothing)
+	)
+happyReduction_91 _ _  = notHappyAtAll 
+
+happyReduce_92 = happySpecReduce_1 30# happyReduction_92
+happyReduction_92 (HappyTerminal (T_idl_type happy_var_1))
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_92 _  = notHappyAtAll 
+
+happyReduce_93 = happyMonadReduce 1# 30# happyReduction_93
+happyReduction_93 (_ `HappyStk`
+	happyRest)
+	 = happyThen ( dumpErrMsg >> return TyVoid
+	) (\r -> happyReturn (HappyAbsSyn30 r))
+
+happyReduce_94 = happySpecReduce_1 31# happyReduction_94
+happyReduction_94 _
+	 =  HappyAbsSyn30
+		 (TyInteger Short
+	)
+
+happyReduce_95 = happySpecReduce_1 31# happyReduction_95
+happyReduction_95 _
+	 =  HappyAbsSyn30
+		 (TyInteger Long
+	)
+
+happyReduce_96 = happySpecReduce_2 31# happyReduction_96
+happyReduction_96 _
+	_
+	 =  HappyAbsSyn30
+		 (TyInteger LongLong
+	)
+
+happyReduce_97 = happySpecReduce_1 31# happyReduction_97
+happyReduction_97 _
+	 =  HappyAbsSyn30
+		 (TyInteger LongLong
+	)
+
+happyReduce_98 = happySpecReduce_1 31# happyReduction_98
+happyReduction_98 _
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned False) (TyInteger LongLong)
+	)
+
+happyReduce_99 = happySpecReduce_1 32# happyReduction_99
+happyReduction_99 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_99 _  = notHappyAtAll 
+
+happyReduce_100 = happySpecReduce_2 32# happyReduction_100
+happyReduction_100 _
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_100 _ _  = notHappyAtAll 
+
+happyReduce_101 = happySpecReduce_1 32# happyReduction_101
+happyReduction_101 _
+	 =  HappyAbsSyn30
+		 (TyInteger Natural
+	)
+
+happyReduce_102 = happySpecReduce_1 33# happyReduction_102
+happyReduction_102 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_102 _  = notHappyAtAll 
+
+happyReduce_103 = happySpecReduce_1 33# happyReduction_103
+happyReduction_103 _
+	 =  HappyAbsSyn30
+		 (TyChar
+	)
+
+happyReduce_104 = happySpecReduce_1 33# happyReduction_104
+happyReduction_104 _
+	 =  HappyAbsSyn30
+		 (TyWChar
+	)
+
+happyReduce_105 = happySpecReduce_1 33# happyReduction_105
+happyReduction_105 (HappyTerminal (T_float happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyFloat happy_var_1
+	)
+happyReduction_105 _  = notHappyAtAll 
+
+happyReduce_106 = happySpecReduce_1 33# happyReduction_106
+happyReduction_106 _
+	 =  HappyAbsSyn30
+		 (TyVoid
+	)
+
+happyReduce_107 = happySpecReduce_1 33# happyReduction_107
+happyReduction_107 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_107 _  = notHappyAtAll 
+
+happyReduce_108 = happySpecReduce_3 33# happyReduction_108
+happyReduction_108 _
+	_
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyArray happy_var_1 []
+	)
+happyReduction_108 _ _ _  = notHappyAtAll 
+
+happyReduce_109 = happySpecReduce_1 33# happyReduction_109
+happyReduction_109 _
+	 =  HappyAbsSyn30
+		 (TySigned True
+	)
+
+happyReduce_110 = happySpecReduce_1 33# happyReduction_110
+happyReduction_110 _
+	 =  HappyAbsSyn30
+		 (TySigned False
+	)
+
+happyReduce_111 = happySpecReduce_2 33# happyReduction_111
+happyReduction_111 (HappyAbsSyn30  happy_var_2)
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned False) happy_var_2
+	)
+happyReduction_111 _ _  = notHappyAtAll 
+
+happyReduce_112 = happySpecReduce_2 33# happyReduction_112
+happyReduction_112 (HappyAbsSyn30  happy_var_2)
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned True)  happy_var_2
+	)
+happyReduction_112 _ _  = notHappyAtAll 
+
+happyReduce_113 = happySpecReduce_3 33# happyReduction_113
+happyReduction_113 _
+	_
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned False) happy_var_1
+	)
+happyReduction_113 _ _ _  = notHappyAtAll 
+
+happyReduce_114 = happySpecReduce_3 33# happyReduction_114
+happyReduction_114 _
+	_
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned True)  happy_var_1
+	)
+happyReduction_114 _ _ _  = notHappyAtAll 
+
+happyReduce_115 = happySpecReduce_2 33# happyReduction_115
+happyReduction_115 _
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned False) TyChar
+	)
+
+happyReduce_116 = happySpecReduce_2 33# happyReduction_116
+happyReduction_116 _
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned True)  TyChar
+	)
+
+happyReduce_117 = happySpecReduce_1 33# happyReduction_117
+happyReduction_117 (HappyTerminal (T_type happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_117 _  = notHappyAtAll 
+
+happyReduce_118 = happySpecReduce_2 33# happyReduction_118
+happyReduction_118 _
+	_
+	 =  HappyAbsSyn30
+		 (TyPointer TyVoid
+	)
+
+happyReduce_119 = happySpecReduce_1 33# happyReduction_119
+happyReduction_119 (HappyTerminal (T_idl_type happy_var_1))
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_119 _  = notHappyAtAll 
+
+happyReduce_120 = happyMonadReduce 1# 33# happyReduction_120
+happyReduction_120 (_ `HappyStk`
+	happyRest)
+	 = happyThen ( dumpErrMsg >> return TyVoid
+	) (\r -> happyReturn (HappyAbsSyn30 r))
+
+happyReduce_121 = happySpecReduce_1 34# happyReduction_121
+happyReduction_121 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_121 _  = notHappyAtAll 
+
+happyReduce_122 = happySpecReduce_1 35# happyReduction_122
+happyReduction_122 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_122 _  = notHappyAtAll 
+
+happyReduce_123 = happyReduce 5# 35# happyReduction_123
+happyReduction_123 ((HappyAbsSyn34  happy_var_5) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn34  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn34  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn34
+		 (Cond happy_var_1 happy_var_3 happy_var_5
+	) `HappyStk` happyRest
+
+happyReduce_124 = happySpecReduce_1 36# happyReduction_124
+happyReduction_124 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_124 _  = notHappyAtAll 
+
+happyReduce_125 = happySpecReduce_3 36# happyReduction_125
+happyReduction_125 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary LogOr happy_var_1 happy_var_3
+	)
+happyReduction_125 _ _ _  = notHappyAtAll 
+
+happyReduce_126 = happySpecReduce_1 37# happyReduction_126
+happyReduction_126 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_126 _  = notHappyAtAll 
+
+happyReduce_127 = happySpecReduce_3 37# happyReduction_127
+happyReduction_127 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary LogAnd happy_var_1 happy_var_3
+	)
+happyReduction_127 _ _ _  = notHappyAtAll 
+
+happyReduce_128 = happySpecReduce_1 38# happyReduction_128
+happyReduction_128 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_128 _  = notHappyAtAll 
+
+happyReduce_129 = happySpecReduce_3 38# happyReduction_129
+happyReduction_129 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Or happy_var_1 happy_var_3
+	)
+happyReduction_129 _ _ _  = notHappyAtAll 
+
+happyReduce_130 = happySpecReduce_1 39# happyReduction_130
+happyReduction_130 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_130 _  = notHappyAtAll 
+
+happyReduce_131 = happySpecReduce_3 39# happyReduction_131
+happyReduction_131 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Xor happy_var_1 happy_var_3
+	)
+happyReduction_131 _ _ _  = notHappyAtAll 
+
+happyReduce_132 = happySpecReduce_1 40# happyReduction_132
+happyReduction_132 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_132 _  = notHappyAtAll 
+
+happyReduce_133 = happySpecReduce_3 40# happyReduction_133
+happyReduction_133 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary And happy_var_1 happy_var_3
+	)
+happyReduction_133 _ _ _  = notHappyAtAll 
+
+happyReduce_134 = happySpecReduce_1 41# happyReduction_134
+happyReduction_134 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_134 _  = notHappyAtAll 
+
+happyReduce_135 = happySpecReduce_3 41# happyReduction_135
+happyReduction_135 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Eq happy_var_1 happy_var_3
+	)
+happyReduction_135 _ _ _  = notHappyAtAll 
+
+happyReduce_136 = happySpecReduce_1 42# happyReduction_136
+happyReduction_136 _
+	 =  HappyAbsSyn42
+		 (Eq
+	)
+
+happyReduce_137 = happySpecReduce_1 42# happyReduction_137
+happyReduction_137 _
+	 =  HappyAbsSyn42
+		 (Ne
+	)
+
+happyReduce_138 = happySpecReduce_1 43# happyReduction_138
+happyReduction_138 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_138 _  = notHappyAtAll 
+
+happyReduce_139 = happySpecReduce_3 43# happyReduction_139
+happyReduction_139 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Lt happy_var_1 happy_var_3
+	)
+happyReduction_139 _ _ _  = notHappyAtAll 
+
+happyReduce_140 = happySpecReduce_3 43# happyReduction_140
+happyReduction_140 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Le happy_var_1 happy_var_3
+	)
+happyReduction_140 _ _ _  = notHappyAtAll 
+
+happyReduce_141 = happySpecReduce_3 43# happyReduction_141
+happyReduction_141 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Ge happy_var_1 happy_var_3
+	)
+happyReduction_141 _ _ _  = notHappyAtAll 
+
+happyReduce_142 = happySpecReduce_3 43# happyReduction_142
+happyReduction_142 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Gt happy_var_1 happy_var_3
+	)
+happyReduction_142 _ _ _  = notHappyAtAll 
+
+happyReduce_143 = happySpecReduce_1 44# happyReduction_143
+happyReduction_143 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_143 _  = notHappyAtAll 
+
+happyReduce_144 = happySpecReduce_3 44# happyReduction_144
+happyReduction_144 (HappyAbsSyn34  happy_var_3)
+	(HappyTerminal (T_shift happy_var_2))
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary (Shift happy_var_2) happy_var_1 happy_var_3
+	)
+happyReduction_144 _ _ _  = notHappyAtAll 
+
+happyReduce_145 = happySpecReduce_1 45# happyReduction_145
+happyReduction_145 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_145 _  = notHappyAtAll 
+
+happyReduce_146 = happySpecReduce_3 45# happyReduction_146
+happyReduction_146 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Add happy_var_1 happy_var_3
+	)
+happyReduction_146 _ _ _  = notHappyAtAll 
+
+happyReduce_147 = happySpecReduce_3 45# happyReduction_147
+happyReduction_147 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Sub happy_var_1 happy_var_3
+	)
+happyReduction_147 _ _ _  = notHappyAtAll 
+
+happyReduce_148 = happySpecReduce_1 46# happyReduction_148
+happyReduction_148 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_148 _  = notHappyAtAll 
+
+happyReduce_149 = happySpecReduce_3 46# happyReduction_149
+happyReduction_149 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Mul happy_var_1 happy_var_3
+	)
+happyReduction_149 _ _ _  = notHappyAtAll 
+
+happyReduce_150 = happySpecReduce_3 46# happyReduction_150
+happyReduction_150 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Div happy_var_1 happy_var_3
+	)
+happyReduction_150 _ _ _  = notHappyAtAll 
+
+happyReduce_151 = happySpecReduce_3 46# happyReduction_151
+happyReduction_151 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Binary Mod happy_var_1 happy_var_3
+	)
+happyReduction_151 _ _ _  = notHappyAtAll 
+
+happyReduce_152 = happySpecReduce_1 47# happyReduction_152
+happyReduction_152 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_152 _  = notHappyAtAll 
+
+happyReduce_153 = happyReduce 4# 47# happyReduction_153
+happyReduction_153 ((HappyAbsSyn34  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn30  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn34
+		 (Cast happy_var_2 happy_var_4
+	) `HappyStk` happyRest
+
+happyReduce_154 = happySpecReduce_1 48# happyReduction_154
+happyReduction_154 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn34
+		 (happy_var_1
+	)
+happyReduction_154 _  = notHappyAtAll 
+
+happyReduce_155 = happyReduce 4# 48# happyReduction_155
+happyReduction_155 (_ `HappyStk`
+	(HappyAbsSyn30  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn34
+		 (Sizeof happy_var_3
+	) `HappyStk` happyRest
+
+happyReduce_156 = happySpecReduce_2 48# happyReduction_156
+happyReduction_156 (HappyAbsSyn34  happy_var_2)
+	(HappyAbsSyn49  happy_var_1)
+	 =  HappyAbsSyn34
+		 (Unary happy_var_1 happy_var_2
+	)
+happyReduction_156 _ _  = notHappyAtAll 
+
+happyReduce_157 = happySpecReduce_1 49# happyReduction_157
+happyReduction_157 _
+	 =  HappyAbsSyn49
+		 (Minus
+	)
+
+happyReduce_158 = happySpecReduce_1 49# happyReduction_158
+happyReduction_158 _
+	 =  HappyAbsSyn49
+		 (Plus
+	)
+
+happyReduce_159 = happySpecReduce_1 49# happyReduction_159
+happyReduction_159 _
+	 =  HappyAbsSyn49
+		 (Not
+	)
+
+happyReduce_160 = happySpecReduce_1 49# happyReduction_160
+happyReduction_160 _
+	 =  HappyAbsSyn49
+		 (Negate
+	)
+
+happyReduce_161 = happySpecReduce_1 50# happyReduction_161
+happyReduction_161 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn34
+		 (let (Id i) = happy_var_1 in Var i
+	)
+happyReduction_161 _  = notHappyAtAll 
+
+happyReduce_162 = happySpecReduce_1 50# happyReduction_162
+happyReduction_162 (HappyTerminal (T_literal happy_var_1))
+	 =  HappyAbsSyn34
+		 (Lit happy_var_1
+	)
+happyReduction_162 _  = notHappyAtAll 
+
+happyReduce_163 = happySpecReduce_1 50# happyReduction_163
+happyReduction_163 (HappyTerminal (T_string_lit happy_var_1))
+	 =  HappyAbsSyn34
+		 (Lit (StringLit happy_var_1)
+	)
+happyReduction_163 _  = notHappyAtAll 
+
+happyReduce_164 = happySpecReduce_3 50# happyReduction_164
+happyReduction_164 _
+	(HappyAbsSyn34  happy_var_2)
+	_
+	 =  HappyAbsSyn34
+		 (happy_var_2
+	)
+happyReduction_164 _ _ _  = notHappyAtAll 
+
+happyReduce_165 = happyMonadReduce 6# 51# happyReduction_165
+happyReduction_165 (_ `HappyStk`
+	(HappyAbsSyn63  happy_var_5) `HappyStk`
+	(HappyAbsSyn30  happy_var_4) `HappyStk`
+	(HappyAbsSyn16  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = happyThen ( let decls = reverse happy_var_5 in addTypes decls >> return (Typedef happy_var_4 happy_var_3 decls)
+	) (\r -> happyReturn (HappyAbsSyn9 r))
+
+happyReduce_166 = happySpecReduce_2 51# happyReduction_166
+happyReduction_166 (HappyAbsSyn30  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn9
+		 (Attributed happy_var_1 (TypeDecl happy_var_2)
+	)
+happyReduction_166 _ _  = notHappyAtAll 
+
+happyReduce_167 = happySpecReduce_1 51# happyReduction_167
+happyReduction_167 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn9
+		 (TypeDecl happy_var_1
+	)
+happyReduction_167 _  = notHappyAtAll 
+
+happyReduce_168 = happyReduce 6# 51# happyReduction_168
+happyReduction_168 ((HappyAbsSyn34  happy_var_6) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_4) `HappyStk`
+	(HappyAbsSyn30  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn16  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn9
+		 (Constant happy_var_4 happy_var_1 happy_var_3 happy_var_6
+	) `HappyStk` happyRest
+
+happyReduce_169 = happyReduce 5# 51# happyReduction_169
+happyReduction_169 ((HappyAbsSyn34  happy_var_5) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_3) `HappyStk`
+	(HappyAbsSyn30  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn9
+		 (Constant happy_var_3 [] happy_var_2 happy_var_5
+	) `HappyStk` happyRest
+
+happyReduce_170 = happyMonadReduce 6# 51# happyReduction_170
+happyReduction_170 (_ `HappyStk`
+	(HappyAbsSyn63  happy_var_5) `HappyStk`
+	(HappyAbsSyn30  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = happyThen ( let decls = reverse happy_var_5 in addTypes decls >> return (ExternDecl happy_var_4 decls)
+	) (\r -> happyReturn (HappyAbsSyn9 r))
+
+happyReduce_171 = happySpecReduce_1 52# happyReduction_171
+happyReduction_171 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_171 _  = notHappyAtAll 
+
+happyReduce_172 = happySpecReduce_3 52# happyReduction_172
+happyReduction_172 _
+	_
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyArray happy_var_1 []
+	)
+happyReduction_172 _ _ _  = notHappyAtAll 
+
+happyReduce_173 = happyReduce 4# 52# happyReduction_173
+happyReduction_173 (_ `HappyStk`
+	(HappyAbsSyn34  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn30  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn30
+		 (TyArray happy_var_1 [happy_var_3]
+	) `HappyStk` happyRest
+
+happyReduce_174 = happySpecReduce_2 52# happyReduction_174
+happyReduction_174 (HappyAbsSyn54  happy_var_2)
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyApply (TyQualifier happy_var_2) happy_var_1
+	)
+happyReduction_174 _ _  = notHappyAtAll 
+
+happyReduce_175 = happySpecReduce_2 52# happyReduction_175
+happyReduction_175 (HappyAbsSyn30  happy_var_2)
+	(HappyAbsSyn54  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyApply (TyQualifier happy_var_1) happy_var_2
+	)
+happyReduction_175 _ _  = notHappyAtAll 
+
+happyReduce_176 = happySpecReduce_1 53# happyReduction_176
+happyReduction_176 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_176 _  = notHappyAtAll 
+
+happyReduce_177 = happySpecReduce_3 53# happyReduction_177
+happyReduction_177 _
+	_
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyArray happy_var_1 []
+	)
+happyReduction_177 _ _ _  = notHappyAtAll 
+
+happyReduce_178 = happySpecReduce_2 53# happyReduction_178
+happyReduction_178 (HappyAbsSyn54  happy_var_2)
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyApply (TyQualifier happy_var_2) happy_var_1
+	)
+happyReduction_178 _ _  = notHappyAtAll 
+
+happyReduce_179 = happySpecReduce_1 54# happyReduction_179
+happyReduction_179 _
+	 =  HappyAbsSyn54
+		 (Const
+	)
+
+happyReduce_180 = happySpecReduce_1 54# happyReduction_180
+happyReduction_180 _
+	 =  HappyAbsSyn54
+		 (Volatile
+	)
+
+happyReduce_181 = happySpecReduce_1 55# happyReduction_181
+happyReduction_181 (HappyTerminal (T_float happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyFloat happy_var_1
+	)
+happyReduction_181 _  = notHappyAtAll 
+
+happyReduce_182 = happySpecReduce_1 55# happyReduction_182
+happyReduction_182 _
+	 =  HappyAbsSyn30
+		 (TyChar
+	)
+
+happyReduce_183 = happySpecReduce_1 55# happyReduction_183
+happyReduction_183 _
+	 =  HappyAbsSyn30
+		 (TyWChar
+	)
+
+happyReduce_184 = happySpecReduce_1 55# happyReduction_184
+happyReduction_184 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_184 _  = notHappyAtAll 
+
+happyReduce_185 = happySpecReduce_1 55# happyReduction_185
+happyReduction_185 _
+	 =  HappyAbsSyn30
+		 (TyVoid
+	)
+
+happyReduce_186 = happySpecReduce_1 55# happyReduction_186
+happyReduction_186 _
+	 =  HappyAbsSyn30
+		 (TySigned True
+	)
+
+happyReduce_187 = happySpecReduce_1 55# happyReduction_187
+happyReduction_187 _
+	 =  HappyAbsSyn30
+		 (TySigned False
+	)
+
+happyReduce_188 = happySpecReduce_2 55# happyReduction_188
+happyReduction_188 (HappyAbsSyn30  happy_var_2)
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned True) happy_var_2
+	)
+happyReduction_188 _ _  = notHappyAtAll 
+
+happyReduce_189 = happySpecReduce_3 55# happyReduction_189
+happyReduction_189 (HappyAbsSyn30  happy_var_3)
+	_
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned True) happy_var_3
+	)
+happyReduction_189 _ _ _  = notHappyAtAll 
+
+happyReduce_190 = happySpecReduce_2 55# happyReduction_190
+happyReduction_190 (HappyAbsSyn30  happy_var_2)
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned False) happy_var_2
+	)
+happyReduction_190 _ _  = notHappyAtAll 
+
+happyReduce_191 = happySpecReduce_3 55# happyReduction_191
+happyReduction_191 (HappyAbsSyn30  happy_var_3)
+	_
+	_
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned False) happy_var_3
+	)
+happyReduction_191 _ _ _  = notHappyAtAll 
+
+happyReduce_192 = happySpecReduce_3 55# happyReduction_192
+happyReduction_192 _
+	_
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned True)  happy_var_1
+	)
+happyReduction_192 _ _ _  = notHappyAtAll 
+
+happyReduce_193 = happySpecReduce_3 55# happyReduction_193
+happyReduction_193 _
+	_
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyApply (TySigned False) happy_var_1
+	)
+happyReduction_193 _ _ _  = notHappyAtAll 
+
+happyReduce_194 = happySpecReduce_1 55# happyReduction_194
+happyReduction_194 (HappyTerminal (T_id happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_194 _  = notHappyAtAll 
+
+happyReduce_195 = happySpecReduce_1 55# happyReduction_195
+happyReduction_195 (HappyTerminal (T_type happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_195 _  = notHappyAtAll 
+
+happyReduce_196 = happySpecReduce_1 55# happyReduction_196
+happyReduction_196 (HappyTerminal (T_idl_type happy_var_1))
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_196 _  = notHappyAtAll 
+
+happyReduce_197 = happySpecReduce_3 55# happyReduction_197
+happyReduction_197 _
+	(HappyAbsSyn30  happy_var_2)
+	_
+	 =  HappyAbsSyn30
+		 (TySafeArray happy_var_2
+	)
+happyReduction_197 _ _ _  = notHappyAtAll 
+
+happyReduce_198 = happySpecReduce_1 55# happyReduction_198
+happyReduction_198 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_198 _  = notHappyAtAll 
+
+happyReduce_199 = happySpecReduce_1 55# happyReduction_199
+happyReduction_199 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_199 _  = notHappyAtAll 
+
+happyReduce_200 = happyMonadReduce 1# 55# happyReduction_200
+happyReduction_200 (_ `HappyStk`
+	happyRest)
+	 = happyThen ( dumpErrMsg >> return TyVoid
+	) (\r -> happyReturn (HappyAbsSyn30 r))
+
+happyReduce_201 = happySpecReduce_1 56# happyReduction_201
+happyReduction_201 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_201 _  = notHappyAtAll 
+
+happyReduce_202 = happySpecReduce_1 56# happyReduction_202
+happyReduction_202 _
+	 =  HappyAbsSyn30
+		 (TyChar
+	)
+
+happyReduce_203 = happySpecReduce_1 56# happyReduction_203
+happyReduction_203 (HappyTerminal (T_float happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyFloat happy_var_1
+	)
+happyReduction_203 _  = notHappyAtAll 
+
+happyReduce_204 = happySpecReduce_1 56# happyReduction_204
+happyReduction_204 (HappyTerminal (T_type happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_204 _  = notHappyAtAll 
+
+happyReduce_205 = happySpecReduce_1 56# happyReduction_205
+happyReduction_205 (HappyTerminal (T_idl_type happy_var_1))
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_205 _  = notHappyAtAll 
+
+happyReduce_206 = happySpecReduce_1 57# happyReduction_206
+happyReduction_206 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_206 _  = notHappyAtAll 
+
+happyReduce_207 = happySpecReduce_2 57# happyReduction_207
+happyReduction_207 _
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (TyPointer happy_var_1
+	)
+happyReduction_207 _ _  = notHappyAtAll 
+
+happyReduce_208 = happySpecReduce_1 58# happyReduction_208
+happyReduction_208 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_208 _  = notHappyAtAll 
+
+happyReduce_209 = happySpecReduce_1 58# happyReduction_209
+happyReduction_209 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_209 _  = notHappyAtAll 
+
+happyReduce_210 = happySpecReduce_1 59# happyReduction_210
+happyReduction_210 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_210 _  = notHappyAtAll 
+
+happyReduce_211 = happySpecReduce_1 59# happyReduction_211
+happyReduction_211 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_211 _  = notHappyAtAll 
+
+happyReduce_212 = happyReduce 6# 60# happyReduction_212
+happyReduction_212 ((HappyAbsSyn109  happy_var_6) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn73  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn30
+		 (TyStruct (Just happy_var_2) (reverse happy_var_4) (toPackedAttrib happy_var_6)
+	) `HappyStk` happyRest
+
+happyReduce_213 = happyReduce 5# 60# happyReduction_213
+happyReduction_213 ((HappyAbsSyn109  happy_var_5) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn73  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn30
+		 (TyStruct Nothing (reverse happy_var_3) (toPackedAttrib happy_var_5)
+	) `HappyStk` happyRest
+
+happyReduce_214 = happySpecReduce_2 60# happyReduction_214
+happyReduction_214 (HappyAbsSyn18  happy_var_2)
+	_
+	 =  HappyAbsSyn30
+		 (TyStruct (Just happy_var_2) [] Nothing
+	)
+happyReduction_214 _ _  = notHappyAtAll 
+
+happyReduce_215 = happyReduce 11# 61# happyReduction_215
+happyReduction_215 (_ `HappyStk`
+	(HappyAbsSyn77  happy_var_10) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn75  happy_var_8) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_6) `HappyStk`
+	(HappyAbsSyn30  happy_var_5) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn75  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn30
+		 (TyUnion happy_var_2 happy_var_5 happy_var_6 happy_var_8 (reverse happy_var_10)
+	) `HappyStk` happyRest
+
+happyReduce_216 = happyReduce 6# 61# happyReduction_216
+happyReduction_216 ((HappyAbsSyn109  happy_var_6) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn62  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn75  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn30
+		 (case happy_var_4 of { Left sw -> TyUnionNon happy_var_2 (reverse sw) ; Right mem -> TyCUnion happy_var_2 (reverse mem) (toPackedAttrib happy_var_6) }
+	) `HappyStk` happyRest
+
+happyReduce_217 = happySpecReduce_3 61# happyReduction_217
+happyReduction_217 (HappyAbsSyn109  happy_var_3)
+	(HappyAbsSyn18  happy_var_2)
+	_
+	 =  HappyAbsSyn30
+		 (TyCUnion (Just happy_var_2) [] (toPackedAttrib happy_var_3)
+	)
+happyReduction_217 _ _ _  = notHappyAtAll 
+
+happyReduce_218 = happySpecReduce_1 62# happyReduction_218
+happyReduction_218 (HappyAbsSyn77  happy_var_1)
+	 =  HappyAbsSyn62
+		 (Left happy_var_1
+	)
+happyReduction_218 _  = notHappyAtAll 
+
+happyReduce_219 = happySpecReduce_1 62# happyReduction_219
+happyReduction_219 (HappyAbsSyn73  happy_var_1)
+	 =  HappyAbsSyn62
+		 (Right happy_var_1
+	)
+happyReduction_219 _  = notHappyAtAll 
+
+happyReduce_220 = happySpecReduce_1 63# happyReduction_220
+happyReduction_220 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn63
+		 ([ happy_var_1 ]
+	)
+happyReduction_220 _  = notHappyAtAll 
+
+happyReduce_221 = happySpecReduce_3 63# happyReduction_221
+happyReduction_221 (HappyAbsSyn18  happy_var_3)
+	_
+	(HappyAbsSyn63  happy_var_1)
+	 =  HappyAbsSyn63
+		 (happy_var_3 : happy_var_1
+	)
+happyReduction_221 _ _ _  = notHappyAtAll 
+
+happyReduce_222 = happySpecReduce_2 64# happyReduction_222
+happyReduction_222 (HappyAbsSyn18  happy_var_2)
+	(HappyAbsSyn65  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1 happy_var_2
+	)
+happyReduction_222 _ _  = notHappyAtAll 
+
+happyReduce_223 = happySpecReduce_1 64# happyReduction_223
+happyReduction_223 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_223 _  = notHappyAtAll 
+
+happyReduce_224 = happySpecReduce_2 64# happyReduction_224
+happyReduction_224 (HappyAbsSyn18  happy_var_2)
+	(HappyAbsSyn65  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1 happy_var_2
+	)
+happyReduction_224 _ _  = notHappyAtAll 
+
+happyReduce_225 = happySpecReduce_1 64# happyReduction_225
+happyReduction_225 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_225 _  = notHappyAtAll 
+
+happyReduce_226 = happySpecReduce_1 65# happyReduction_226
+happyReduction_226 (HappyAbsSyn109  happy_var_1)
+	 =  HappyAbsSyn65
+		 (toCConvAttrib happy_var_1
+	)
+happyReduction_226 _  = notHappyAtAll 
+
+happyReduce_227 = happySpecReduce_1 65# happyReduction_227
+happyReduction_227 (HappyTerminal (T_callconv happy_var_1))
+	 =  HappyAbsSyn65
+		 (CConvId happy_var_1
+	)
+happyReduction_227 _  = notHappyAtAll 
+
+happyReduce_228 = happySpecReduce_1 66# happyReduction_228
+happyReduction_228 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_228 _  = notHappyAtAll 
+
+happyReduce_229 = happySpecReduce_3 66# happyReduction_229
+happyReduction_229 _
+	(HappyAbsSyn18  happy_var_2)
+	_
+	 =  HappyAbsSyn18
+		 (happy_var_2
+	)
+happyReduction_229 _ _ _  = notHappyAtAll 
+
+happyReduce_230 = happySpecReduce_1 66# happyReduction_230
+happyReduction_230 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_230 _  = notHappyAtAll 
+
+happyReduce_231 = happySpecReduce_1 66# happyReduction_231
+happyReduction_231 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_231 _  = notHappyAtAll 
+
+happyReduce_232 = happySpecReduce_1 67# happyReduction_232
+happyReduction_232 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_232 _  = notHappyAtAll 
+
+happyReduce_233 = happySpecReduce_3 67# happyReduction_233
+happyReduction_233 (HappyTerminal (T_literal happy_var_3))
+	_
+	(HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 ((let { (Id nm) = happy_var_1 ; x = mkBitField nm happy_var_3 } in BitFieldId x happy_var_1)
+	)
+happyReduction_233 _ _ _  = notHappyAtAll 
+
+happyReduce_234 = happySpecReduce_3 67# happyReduction_234
+happyReduction_234 (HappyTerminal (T_literal happy_var_3))
+	_
+	(HappyTerminal (T_type happy_var_1))
+	 =  HappyAbsSyn18
+		 ((let x = mkBitField happy_var_1 happy_var_3 in BitFieldId x (Id happy_var_1))
+	)
+happyReduction_234 _ _ _  = notHappyAtAll 
+
+happyReduce_235 = happySpecReduce_2 67# happyReduction_235
+happyReduction_235 (HappyTerminal (T_literal happy_var_2))
+	_
+	 =  HappyAbsSyn18
+		 ((let x = mkBitField "" happy_var_2 in BitFieldId x (Id ""))
+	)
+happyReduction_235 _ _  = notHappyAtAll 
+
+happyReduce_236 = happySpecReduce_1 67# happyReduction_236
+happyReduction_236 (HappyTerminal (T_type happy_var_1))
+	 =  HappyAbsSyn18
+		 ((Id happy_var_1)
+	)
+happyReduction_236 _  = notHappyAtAll 
+
+happyReduce_237 = happySpecReduce_1 67# happyReduction_237
+happyReduction_237 (HappyTerminal (T_mode happy_var_1))
+	 =  HappyAbsSyn18
+		 ((if happy_var_1 == In then Id "in" else Id "out")
+	)
+happyReduction_237 _  = notHappyAtAll 
+
+happyReduce_238 = happySpecReduce_2 68# happyReduction_238
+happyReduction_238 (HappyAbsSyn18  happy_var_2)
+	(HappyAbsSyn71  happy_var_1)
+	 =  HappyAbsSyn18
+		 (Pointed happy_var_1 happy_var_2
+	)
+happyReduction_238 _ _  = notHappyAtAll 
+
+happyReduce_239 = happySpecReduce_3 68# happyReduction_239
+happyReduction_239 (HappyAbsSyn18  happy_var_3)
+	(HappyTerminal (T_callconv happy_var_2))
+	(HappyAbsSyn71  happy_var_1)
+	 =  HappyAbsSyn18
+		 (Pointed happy_var_1 (CConvId happy_var_2 happy_var_3)
+	)
+happyReduction_239 _ _ _  = notHappyAtAll 
+
+happyReduce_240 = happySpecReduce_3 68# happyReduction_240
+happyReduction_240 (HappyAbsSyn18  happy_var_3)
+	(HappyAbsSyn109  happy_var_2)
+	(HappyAbsSyn71  happy_var_1)
+	 =  HappyAbsSyn18
+		 (Pointed happy_var_1 (toCConvAttrib happy_var_2 happy_var_3)
+	)
+happyReduction_240 _ _ _  = notHappyAtAll 
+
+happyReduce_241 = happySpecReduce_3 69# happyReduction_241
+happyReduction_241 _
+	_
+	(HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (ArrayId happy_var_1 []
+	)
+happyReduction_241 _ _ _  = notHappyAtAll 
+
+happyReduce_242 = happyReduce 4# 69# happyReduction_242
+happyReduction_242 (_ `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (ArrayId happy_var_1 []
+	) `HappyStk` happyRest
+
+happyReduce_243 = happyReduce 4# 69# happyReduction_243
+happyReduction_243 (_ `HappyStk`
+	(HappyAbsSyn34  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (ArrayId happy_var_1 [happy_var_3]
+	) `HappyStk` happyRest
+
+happyReduce_244 = happyReduce 7# 69# happyReduction_244
+happyReduction_244 (_ `HappyStk`
+	(HappyAbsSyn34  happy_var_6) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn34  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (ArrayId happy_var_1 [happy_var_3,happy_var_6]
+	) `HappyStk` happyRest
+
+happyReduce_245 = happyReduce 4# 70# happyReduction_245
+happyReduction_245 (_ `HappyStk`
+	(HappyAbsSyn106  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (mkFunId happy_var_1 (reverse happy_var_3)
+	) `HappyStk` happyRest
+
+happyReduce_246 = happySpecReduce_3 70# happyReduction_246
+happyReduction_246 _
+	_
+	(HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (mkFunId happy_var_1 []
+	)
+happyReduction_246 _ _ _  = notHappyAtAll 
+
+happyReduce_247 = happySpecReduce_1 71# happyReduction_247
+happyReduction_247 _
+	 =  HappyAbsSyn71
+		 ([[]]
+	)
+
+happyReduce_248 = happySpecReduce_2 71# happyReduction_248
+happyReduction_248 (HappyAbsSyn72  happy_var_2)
+	_
+	 =  HappyAbsSyn71
+		 ([happy_var_2]
+	)
+happyReduction_248 _ _  = notHappyAtAll 
+
+happyReduce_249 = happySpecReduce_2 71# happyReduction_249
+happyReduction_249 (HappyAbsSyn71  happy_var_2)
+	_
+	 =  HappyAbsSyn71
+		 ([] : happy_var_2
+	)
+happyReduction_249 _ _  = notHappyAtAll 
+
+happyReduce_250 = happySpecReduce_3 71# happyReduction_250
+happyReduction_250 (HappyAbsSyn71  happy_var_3)
+	(HappyAbsSyn72  happy_var_2)
+	_
+	 =  HappyAbsSyn71
+		 (happy_var_2 : happy_var_3
+	)
+happyReduction_250 _ _ _  = notHappyAtAll 
+
+happyReduce_251 = happySpecReduce_1 72# happyReduction_251
+happyReduction_251 (HappyAbsSyn54  happy_var_1)
+	 =  HappyAbsSyn72
+		 ([happy_var_1]
+	)
+happyReduction_251 _  = notHappyAtAll 
+
+happyReduce_252 = happySpecReduce_2 72# happyReduction_252
+happyReduction_252 (HappyAbsSyn54  happy_var_2)
+	(HappyAbsSyn72  happy_var_1)
+	 =  HappyAbsSyn72
+		 (happy_var_2 : happy_var_1
+	)
+happyReduction_252 _ _  = notHappyAtAll 
+
+happyReduce_253 = happySpecReduce_3 73# happyReduction_253
+happyReduction_253 _
+	_
+	(HappyAbsSyn74  happy_var_1)
+	 =  HappyAbsSyn73
+		 ([ happy_var_1 ]
+	)
+happyReduction_253 _ _ _  = notHappyAtAll 
+
+happyReduce_254 = happyReduce 4# 73# happyReduction_254
+happyReduction_254 (_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn74  happy_var_2) `HappyStk`
+	(HappyAbsSyn73  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn73
+		 (happy_var_2 : happy_var_1
+	) `HappyStk` happyRest
+
+happyReduce_255 = happySpecReduce_3 74# happyReduction_255
+happyReduction_255 (HappyAbsSyn63  happy_var_3)
+	(HappyAbsSyn30  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn74
+		 ((happy_var_2, happy_var_1, reverse happy_var_3)
+	)
+happyReduction_255 _ _ _  = notHappyAtAll 
+
+happyReduce_256 = happySpecReduce_2 74# happyReduction_256
+happyReduction_256 (HappyAbsSyn30  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn74
+		 ((happy_var_2, happy_var_1, [])
+	)
+happyReduction_256 _ _  = notHappyAtAll 
+
+happyReduce_257 = happySpecReduce_0 75# happyReduction_257
+happyReduction_257  =  HappyAbsSyn75
+		 (Nothing
+	)
+
+happyReduce_258 = happySpecReduce_1 75# happyReduction_258
+happyReduction_258 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn75
+		 (Just happy_var_1
+	)
+happyReduction_258 _  = notHappyAtAll 
+
+happyReduce_259 = happySpecReduce_1 76# happyReduction_259
+happyReduction_259 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_259 _  = notHappyAtAll 
+
+happyReduce_260 = happySpecReduce_1 76# happyReduction_260
+happyReduction_260 _
+	 =  HappyAbsSyn30
+		 (TyChar
+	)
+
+happyReduce_261 = happySpecReduce_1 76# happyReduction_261
+happyReduction_261 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_261 _  = notHappyAtAll 
+
+happyReduce_262 = happySpecReduce_1 76# happyReduction_262
+happyReduction_262 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_262 _  = notHappyAtAll 
+
+happyReduce_263 = happySpecReduce_1 76# happyReduction_263
+happyReduction_263 (HappyTerminal (T_id happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_263 _  = notHappyAtAll 
+
+happyReduce_264 = happySpecReduce_1 76# happyReduction_264
+happyReduction_264 (HappyTerminal (T_type happy_var_1))
+	 =  HappyAbsSyn30
+		 (TyName happy_var_1 Nothing
+	)
+happyReduction_264 _  = notHappyAtAll 
+
+happyReduce_265 = happySpecReduce_2 77# happyReduction_265
+happyReduction_265 _
+	(HappyAbsSyn78  happy_var_1)
+	 =  HappyAbsSyn77
+		 ([ happy_var_1 ]
+	)
+happyReduction_265 _ _  = notHappyAtAll 
+
+happyReduce_266 = happySpecReduce_3 77# happyReduction_266
+happyReduction_266 _
+	(HappyAbsSyn78  happy_var_2)
+	(HappyAbsSyn77  happy_var_1)
+	 =  HappyAbsSyn77
+		 (happy_var_2 : happy_var_1
+	)
+happyReduction_266 _ _ _  = notHappyAtAll 
+
+happyReduce_267 = happySpecReduce_2 78# happyReduction_267
+happyReduction_267 (HappyAbsSyn79  happy_var_2)
+	(HappyAbsSyn81  happy_var_1)
+	 =  HappyAbsSyn78
+		 (Switch  happy_var_1  happy_var_2
+	)
+happyReduction_267 _ _  = notHappyAtAll 
+
+happyReduce_268 = happyReduce 4# 78# happyReduction_268
+happyReduction_268 ((HappyAbsSyn79  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn82  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn78
+		 (Switch [happy_var_2] happy_var_4
+	) `HappyStk` happyRest
+
+happyReduce_269 = happySpecReduce_0 79# happyReduction_269
+happyReduction_269  =  HappyAbsSyn79
+		 (Nothing
+	)
+
+happyReduce_270 = happySpecReduce_2 79# happyReduction_270
+happyReduction_270 (HappyAbsSyn18  happy_var_2)
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn79
+		 (Just (Param happy_var_2 happy_var_1 [])
+	)
+happyReduction_270 _ _  = notHappyAtAll 
+
+happyReduce_271 = happySpecReduce_1 79# happyReduction_271
+happyReduction_271 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn79
+		 (Just (Param (Id "") happy_var_1 [])
+	)
+happyReduction_271 _  = notHappyAtAll 
+
+happyReduce_272 = happySpecReduce_0 80# happyReduction_272
+happyReduction_272  =  HappyAbsSyn79
+		 (Nothing
+	)
+
+happyReduce_273 = happySpecReduce_3 80# happyReduction_273
+happyReduction_273 (HappyAbsSyn18  happy_var_3)
+	(HappyAbsSyn30  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn79
+		 (Just (Param happy_var_3 happy_var_2 happy_var_1)
+	)
+happyReduction_273 _ _ _  = notHappyAtAll 
+
+happyReduce_274 = happySpecReduce_2 80# happyReduction_274
+happyReduction_274 (HappyAbsSyn30  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn79
+		 (Just (Param (Id "") happy_var_2 happy_var_1)
+	)
+happyReduction_274 _ _  = notHappyAtAll 
+
+happyReduce_275 = happySpecReduce_1 81# happyReduction_275
+happyReduction_275 (HappyAbsSyn82  happy_var_1)
+	 =  HappyAbsSyn81
+		 ([ happy_var_1 ]
+	)
+happyReduction_275 _  = notHappyAtAll 
+
+happyReduce_276 = happySpecReduce_2 81# happyReduction_276
+happyReduction_276 (HappyAbsSyn82  happy_var_2)
+	(HappyAbsSyn81  happy_var_1)
+	 =  HappyAbsSyn81
+		 (happy_var_2 : happy_var_1
+	)
+happyReduction_276 _ _  = notHappyAtAll 
+
+happyReduce_277 = happySpecReduce_3 82# happyReduction_277
+happyReduction_277 _
+	(HappyAbsSyn34  happy_var_2)
+	_
+	 =  HappyAbsSyn82
+		 (Case [happy_var_2]
+	)
+happyReduction_277 _ _ _  = notHappyAtAll 
+
+happyReduce_278 = happySpecReduce_2 82# happyReduction_278
+happyReduction_278 _
+	_
+	 =  HappyAbsSyn82
+		 (Default
+	)
+
+happyReduce_279 = happyReduce 4# 83# happyReduction_279
+happyReduction_279 (_ `HappyStk`
+	(HappyAbsSyn84  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn82
+		 (Case (reverse happy_var_3)
+	) `HappyStk` happyRest
+
+happyReduce_280 = happySpecReduce_1 83# happyReduction_280
+happyReduction_280 _
+	 =  HappyAbsSyn82
+		 (Default
+	)
+
+happyReduce_281 = happySpecReduce_1 84# happyReduction_281
+happyReduction_281 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn84
+		 ([ happy_var_1 ]
+	)
+happyReduction_281 _  = notHappyAtAll 
+
+happyReduce_282 = happySpecReduce_3 84# happyReduction_282
+happyReduction_282 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn84  happy_var_1)
+	 =  HappyAbsSyn84
+		 (happy_var_3 : happy_var_1
+	)
+happyReduction_282 _ _ _  = notHappyAtAll 
+
+happyReduce_283 = happySpecReduce_0 85# happyReduction_283
+happyReduction_283  =  HappyAbsSyn84
+		 ([]
+	)
+
+happyReduce_284 = happySpecReduce_1 85# happyReduction_284
+happyReduction_284 (HappyAbsSyn84  happy_var_1)
+	 =  HappyAbsSyn84
+		 (happy_var_1
+	)
+happyReduction_284 _  = notHappyAtAll 
+
+happyReduce_285 = happyReduce 5# 86# happyReduction_285
+happyReduction_285 (_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn87  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn30
+		 (TyEnum Nothing (reverse happy_var_3)
+	) `HappyStk` happyRest
+
+happyReduce_286 = happyReduce 6# 86# happyReduction_286
+happyReduction_286 (_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn87  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn30
+		 (TyEnum (Just happy_var_2) (reverse happy_var_4)
+	) `HappyStk` happyRest
+
+happyReduce_287 = happySpecReduce_2 86# happyReduction_287
+happyReduction_287 (HappyAbsSyn18  happy_var_2)
+	_
+	 =  HappyAbsSyn30
+		 (TyEnum (Just happy_var_2) []
+	)
+happyReduction_287 _ _  = notHappyAtAll 
+
+happyReduce_288 = happySpecReduce_1 87# happyReduction_288
+happyReduction_288 (HappyAbsSyn88  happy_var_1)
+	 =  HappyAbsSyn87
+		 ([ happy_var_1 ]
+	)
+happyReduction_288 _  = notHappyAtAll 
+
+happyReduce_289 = happySpecReduce_3 87# happyReduction_289
+happyReduction_289 (HappyAbsSyn88  happy_var_3)
+	_
+	(HappyAbsSyn87  happy_var_1)
+	 =  HappyAbsSyn87
+		 (happy_var_3 : happy_var_1
+	)
+happyReduction_289 _ _ _  = notHappyAtAll 
+
+happyReduce_290 = happySpecReduce_1 88# happyReduction_290
+happyReduction_290 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn88
+		 ((happy_var_1, [], Nothing)
+	)
+happyReduction_290 _  = notHappyAtAll 
+
+happyReduce_291 = happySpecReduce_2 88# happyReduction_291
+happyReduction_291 (HappyAbsSyn18  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn88
+		 ((happy_var_2, happy_var_1, Nothing)
+	)
+happyReduction_291 _ _  = notHappyAtAll 
+
+happyReduce_292 = happySpecReduce_3 88# happyReduction_292
+happyReduction_292 (HappyAbsSyn34  happy_var_3)
+	_
+	(HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn88
+		 ((happy_var_1, [], Just happy_var_3)
+	)
+happyReduction_292 _ _ _  = notHappyAtAll 
+
+happyReduce_293 = happyReduce 4# 88# happyReduction_293
+happyReduction_293 ((HappyAbsSyn34  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_2) `HappyStk`
+	(HappyAbsSyn16  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn88
+		 ((happy_var_2, happy_var_1, Just happy_var_4)
+	) `HappyStk` happyRest
+
+happyReduce_294 = happyReduce 4# 89# happyReduction_294
+happyReduction_294 (_ `HappyStk`
+	(HappyAbsSyn34  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn90  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn30
+		 (happy_var_1 (Just happy_var_3)
+	) `HappyStk` happyRest
+
+happyReduce_295 = happySpecReduce_1 89# happyReduction_295
+happyReduction_295 (HappyAbsSyn90  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1 Nothing
+	)
+happyReduction_295 _  = notHappyAtAll 
+
+happyReduce_296 = happySpecReduce_1 90# happyReduction_296
+happyReduction_296 _
+	 =  HappyAbsSyn90
+		 (TyString
+	)
+
+happyReduce_297 = happySpecReduce_1 90# happyReduction_297
+happyReduction_297 _
+	 =  HappyAbsSyn90
+		 (TyWString
+	)
+
+happyReduce_298 = happySpecReduce_0 91# happyReduction_298
+happyReduction_298  =  HappyAbsSyn5
+		 ([]
+	)
+
+happyReduce_299 = happySpecReduce_3 91# happyReduction_299
+happyReduction_299 _
+	(HappyAbsSyn9  happy_var_2)
+	(HappyAbsSyn5  happy_var_1)
+	 =  HappyAbsSyn5
+		 (happy_var_2 : happy_var_1
+	)
+happyReduction_299 _ _ _  = notHappyAtAll 
+
+happyReduce_300 = happyReduce 4# 92# happyReduction_300
+happyReduction_300 (_ `HappyStk`
+	(HappyAbsSyn18  happy_var_3) `HappyStk`
+	(HappyAbsSyn30  happy_var_2) `HappyStk`
+	(HappyAbsSyn16  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn9
+		 (let m_id = mkMethodId happy_var_3 in (Attributed happy_var_1 (Operation m_id happy_var_2 Nothing Nothing))
+	) `HappyStk` happyRest
+
+happyReduce_301 = happySpecReduce_3 93# happyReduction_301
+happyReduction_301 _
+	(HappyAbsSyn18  happy_var_2)
+	(HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn9
+		 (let m_id = mkMethodId happy_var_2 in (Operation m_id happy_var_1 Nothing Nothing)
+	)
+happyReduction_301 _ _ _  = notHappyAtAll 
+
+happyReduce_302 = happySpecReduce_1 94# happyReduction_302
+happyReduction_302 (HappyAbsSyn95  happy_var_1)
+	 =  HappyAbsSyn16
+		 (concat happy_var_1
+	)
+happyReduction_302 _  = notHappyAtAll 
+
+happyReduce_303 = happySpecReduce_0 95# happyReduction_303
+happyReduction_303  =  HappyAbsSyn95
+		 ([]
+	)
+
+happyReduce_304 = happySpecReduce_2 95# happyReduction_304
+happyReduction_304 (HappyAbsSyn95  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn95
+		 (happy_var_1 : happy_var_2
+	)
+happyReduction_304 _ _  = notHappyAtAll 
+
+happyReduce_305 = happySpecReduce_2 96# happyReduction_305
+happyReduction_305 _
+	_
+	 =  HappyAbsSyn16
+		 ([]
+	)
+
+happyReduce_306 = happyReduce 4# 96# happyReduction_306
+happyReduction_306 (_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn16  happy_var_2) `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn16
+		 ((reverse happy_var_2)
+	) `HappyStk` happyRest
+
+happyReduce_307 = happySpecReduce_1 97# happyReduction_307
+happyReduction_307 (HappyAbsSyn98  happy_var_1)
+	 =  HappyAbsSyn16
+		 ([ happy_var_1 ]
+	)
+happyReduction_307 _  = notHappyAtAll 
+
+happyReduce_308 = happySpecReduce_3 97# happyReduction_308
+happyReduction_308 (HappyAbsSyn98  happy_var_3)
+	_
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn16
+		 (happy_var_3 : happy_var_1
+	)
+happyReduction_308 _ _ _  = notHappyAtAll 
+
+happyReduce_309 = happySpecReduce_2 98# happyReduction_309
+happyReduction_309 (HappyAbsSyn101  happy_var_2)
+	(HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn98
+		 (Attrib happy_var_1 happy_var_2
+	)
+happyReduction_309 _ _  = notHappyAtAll 
+
+happyReduce_310 = happySpecReduce_1 98# happyReduction_310
+happyReduction_310 _
+	 =  HappyAbsSyn98
+		 (Attrib (Id "string") []
+	)
+
+happyReduce_311 = happySpecReduce_1 98# happyReduction_311
+happyReduction_311 (HappyTerminal (T_mode happy_var_1))
+	 =  HappyAbsSyn98
+		 (Mode happy_var_1
+	)
+happyReduction_311 _  = notHappyAtAll 
+
+happyReduce_312 = happySpecReduce_1 99# happyReduction_312
+happyReduction_312 (HappyAbsSyn98  happy_var_1)
+	 =  HappyAbsSyn16
+		 ([ happy_var_1 ]
+	)
+happyReduction_312 _  = notHappyAtAll 
+
+happyReduce_313 = happySpecReduce_3 99# happyReduction_313
+happyReduction_313 (HappyAbsSyn98  happy_var_3)
+	_
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn16
+		 (happy_var_3 : happy_var_1
+	)
+happyReduction_313 _ _ _  = notHappyAtAll 
+
+happyReduce_314 = happySpecReduce_1 100# happyReduction_314
+happyReduction_314 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn98
+		 (Attrib happy_var_1 []
+	)
+happyReduction_314 _  = notHappyAtAll 
+
+happyReduce_315 = happySpecReduce_1 100# happyReduction_315
+happyReduction_315 _
+	 =  HappyAbsSyn98
+		 (Attrib (Id "default") []
+	)
+
+happyReduce_316 = happySpecReduce_0 101# happyReduction_316
+happyReduction_316  =  HappyAbsSyn101
+		 ([]
+	)
+
+happyReduce_317 = happySpecReduce_3 101# happyReduction_317
+happyReduction_317 _
+	(HappyAbsSyn101  happy_var_2)
+	_
+	 =  HappyAbsSyn101
+		 ((reverse happy_var_2)
+	)
+happyReduction_317 _ _ _  = notHappyAtAll 
+
+happyReduce_318 = happySpecReduce_1 102# happyReduction_318
+happyReduction_318 (HappyAbsSyn103  happy_var_1)
+	 =  HappyAbsSyn101
+		 ([happy_var_1]
+	)
+happyReduction_318 _  = notHappyAtAll 
+
+happyReduce_319 = happySpecReduce_3 102# happyReduction_319
+happyReduction_319 (HappyAbsSyn103  happy_var_3)
+	_
+	(HappyAbsSyn101  happy_var_1)
+	 =  HappyAbsSyn101
+		 (happy_var_3:happy_var_1
+	)
+happyReduction_319 _ _ _  = notHappyAtAll 
+
+happyReduce_320 = happySpecReduce_1 103# happyReduction_320
+happyReduction_320 (HappyAbsSyn34  happy_var_1)
+	 =  HappyAbsSyn103
+		 ((AttrExpr happy_var_1)
+	)
+happyReduction_320 _  = notHappyAtAll 
+
+happyReduce_321 = happySpecReduce_0 103# happyReduction_321
+happyReduction_321  =  HappyAbsSyn103
+		 (EmptyAttr
+	)
+
+happyReduce_322 = happySpecReduce_1 103# happyReduction_322
+happyReduction_322 (HappyTerminal (T_type happy_var_1))
+	 =  HappyAbsSyn103
+		 ((AttrLit (TypeConst happy_var_1))
+	)
+happyReduction_322 _  = notHappyAtAll 
+
+happyReduce_323 = happySpecReduce_2 103# happyReduction_323
+happyReduction_323 (HappyTerminal (T_type happy_var_2))
+	_
+	 =  HappyAbsSyn103
+		 ((AttrLit (TypeConst ("unsigned " ++ happy_var_2)))
+	)
+happyReduction_323 _ _  = notHappyAtAll 
+
+happyReduce_324 = happySpecReduce_2 103# happyReduction_324
+happyReduction_324 (HappyTerminal (T_type happy_var_2))
+	_
+	 =  HappyAbsSyn103
+		 ((AttrLit (TypeConst ("signed " ++ happy_var_2)))
+	)
+happyReduction_324 _ _  = notHappyAtAll 
+
+happyReduce_325 = happySpecReduce_3 103# happyReduction_325
+happyReduction_325 _
+	(HappyTerminal (T_literal happy_var_2))
+	_
+	 =  HappyAbsSyn103
+		 (AttrLit happy_var_2
+	)
+happyReduction_325 _ _ _  = notHappyAtAll 
+
+happyReduce_326 = happySpecReduce_2 103# happyReduction_326
+happyReduction_326 (HappyAbsSyn103  happy_var_2)
+	_
+	 =  HappyAbsSyn103
+		 ((AttrPtr happy_var_2)
+	)
+happyReduction_326 _ _  = notHappyAtAll 
+
+happyReduce_327 = happySpecReduce_1 104# happyReduction_327
+happyReduction_327 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_327 _  = notHappyAtAll 
+
+happyReduce_328 = happySpecReduce_1 104# happyReduction_328
+happyReduction_328 (HappyAbsSyn30  happy_var_1)
+	 =  HappyAbsSyn30
+		 (happy_var_1
+	)
+happyReduction_328 _  = notHappyAtAll 
+
+happyReduce_329 = happySpecReduce_2 105# happyReduction_329
+happyReduction_329 (HappyAbsSyn30  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn105
+		 (Param (Id "") happy_var_2 happy_var_1
+	)
+happyReduction_329 _ _  = notHappyAtAll 
+
+happyReduce_330 = happySpecReduce_3 105# happyReduction_330
+happyReduction_330 (HappyAbsSyn18  happy_var_3)
+	(HappyAbsSyn30  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn105
+		 (Param happy_var_3 happy_var_2 happy_var_1
+	)
+happyReduction_330 _ _ _  = notHappyAtAll 
+
+happyReduce_331 = happySpecReduce_3 105# happyReduction_331
+happyReduction_331 (HappyAbsSyn18  happy_var_3)
+	(HappyAbsSyn30  happy_var_2)
+	(HappyAbsSyn16  happy_var_1)
+	 =  HappyAbsSyn105
+		 (Param happy_var_3 happy_var_2 happy_var_1
+	)
+happyReduction_331 _ _ _  = notHappyAtAll 
+
+happyReduce_332 = happySpecReduce_1 105# happyReduction_332
+happyReduction_332 _
+	 =  HappyAbsSyn105
+		 (Param (Id "vararg") TyVoid []
+	)
+
+happyReduce_333 = happySpecReduce_1 106# happyReduction_333
+happyReduction_333 (HappyAbsSyn105  happy_var_1)
+	 =  HappyAbsSyn106
+		 ([happy_var_1]
+	)
+happyReduction_333 _  = notHappyAtAll 
+
+happyReduce_334 = happySpecReduce_3 106# happyReduction_334
+happyReduction_334 (HappyAbsSyn105  happy_var_3)
+	_
+	(HappyAbsSyn106  happy_var_1)
+	 =  HappyAbsSyn106
+		 (happy_var_3 : happy_var_1
+	)
+happyReduction_334 _ _ _  = notHappyAtAll 
+
+happyReduce_335 = happySpecReduce_1 107# happyReduction_335
+happyReduction_335 (HappyAbsSyn71  happy_var_1)
+	 =  HappyAbsSyn18
+		 (Pointed happy_var_1 (Id "")
+	)
+happyReduction_335 _  = notHappyAtAll 
+
+happyReduce_336 = happySpecReduce_2 107# happyReduction_336
+happyReduction_336 (HappyAbsSyn18  happy_var_2)
+	(HappyAbsSyn65  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1 happy_var_2
+	)
+happyReduction_336 _ _  = notHappyAtAll 
+
+happyReduce_337 = happySpecReduce_1 107# happyReduction_337
+happyReduction_337 (HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (happy_var_1
+	)
+happyReduction_337 _  = notHappyAtAll 
+
+happyReduce_338 = happySpecReduce_2 107# happyReduction_338
+happyReduction_338 (HappyAbsSyn18  happy_var_2)
+	(HappyAbsSyn71  happy_var_1)
+	 =  HappyAbsSyn18
+		 (Pointed happy_var_1 happy_var_2
+	)
+happyReduction_338 _ _  = notHappyAtAll 
+
+happyReduce_339 = happySpecReduce_3 108# happyReduction_339
+happyReduction_339 _
+	(HappyAbsSyn18  happy_var_2)
+	_
+	 =  HappyAbsSyn18
+		 (happy_var_2
+	)
+happyReduction_339 _ _ _  = notHappyAtAll 
+
+happyReduce_340 = happySpecReduce_2 108# happyReduction_340
+happyReduction_340 _
+	_
+	 =  HappyAbsSyn18
+		 (FunId (Id "") Nothing []
+	)
+
+happyReduce_341 = happySpecReduce_3 108# happyReduction_341
+happyReduction_341 _
+	(HappyAbsSyn106  happy_var_2)
+	_
+	 =  HappyAbsSyn18
+		 (FunId (Id "") Nothing happy_var_2
+	)
+happyReduction_341 _ _ _  = notHappyAtAll 
+
+happyReduce_342 = happySpecReduce_3 108# happyReduction_342
+happyReduction_342 _
+	_
+	(HappyAbsSyn18  happy_var_1)
+	 =  HappyAbsSyn18
+		 (FunId happy_var_1 Nothing []
+	)
+happyReduction_342 _ _ _  = notHappyAtAll 
+
+happyReduce_343 = happyReduce 4# 108# happyReduction_343
+happyReduction_343 (_ `HappyStk`
+	(HappyAbsSyn106  happy_var_3) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn18  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn18
+		 (FunId happy_var_1 Nothing happy_var_3
+	) `HappyStk` happyRest
+
+happyReduce_344 = happySpecReduce_0 109# happyReduction_344
+happyReduction_344  =  HappyAbsSyn109
+		 ([]
+	)
+
+happyReduce_345 = happySpecReduce_1 109# happyReduction_345
+happyReduction_345 (HappyAbsSyn109  happy_var_1)
+	 =  HappyAbsSyn109
+		 ((reverse happy_var_1)
+	)
+happyReduction_345 _  = notHappyAtAll 
+
+happyReduce_346 = happySpecReduce_1 110# happyReduction_346
+happyReduction_346 (HappyAbsSyn111  happy_var_1)
+	 =  HappyAbsSyn109
+		 ([happy_var_1]
+	)
+happyReduction_346 _  = notHappyAtAll 
+
+happyReduce_347 = happySpecReduce_2 110# happyReduction_347
+happyReduction_347 (HappyAbsSyn111  happy_var_2)
+	(HappyAbsSyn109  happy_var_1)
+	 =  HappyAbsSyn109
+		 ((happy_var_2:happy_var_1)
+	)
+happyReduction_347 _ _  = notHappyAtAll 
+
+happyReduce_348 = happyReduce 6# 111# happyReduction_348
+happyReduction_348 (_ `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn111  happy_var_4) `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	_ `HappyStk`
+	happyRest)
+	 = HappyAbsSyn111
+		 (happy_var_4
+	) `HappyStk` happyRest
+
+happyReduce_349 = happySpecReduce_1 112# happyReduction_349
+happyReduction_349 (HappyAbsSyn8  happy_var_1)
+	 =  HappyAbsSyn111
+		 (mkGNUAttrib happy_var_1 []
+	)
+happyReduction_349 _  = notHappyAtAll 
+
+happyReduce_350 = happySpecReduce_1 112# happyReduction_350
+happyReduction_350 (HappyTerminal (T_callconv happy_var_1))
+	 =  HappyAbsSyn111
+		 (CConv happy_var_1
+	)
+happyReduction_350 _  = notHappyAtAll 
+
+happyReduce_351 = happyReduce 4# 112# happyReduction_351
+happyReduction_351 (_ `HappyStk`
+	(HappyTerminal (T_id happy_var_3)) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn8  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn111
+		 (mkGNUAttrib happy_var_1 [Var happy_var_3]
+	) `HappyStk` happyRest
+
+happyReduce_352 = happyReduce 6# 112# happyReduction_352
+happyReduction_352 (_ `HappyStk`
+	(HappyAbsSyn84  happy_var_5) `HappyStk`
+	_ `HappyStk`
+	(HappyTerminal (T_id happy_var_3)) `HappyStk`
+	_ `HappyStk`
+	(HappyAbsSyn8  happy_var_1) `HappyStk`
+	happyRest)
+	 = HappyAbsSyn111
+		 (mkGNUAttrib happy_var_1 (Var happy_var_3:happy_var_5)
+	) `HappyStk` happyRest
+
+happyReduce_353 = happySpecReduce_1 113# happyReduction_353
+happyReduction_353 (HappyTerminal (T_id happy_var_1))
+	 =  HappyAbsSyn8
+		 (happy_var_1
+	)
+happyReduction_353 _  = notHappyAtAll 
+
+happyReduce_354 = happySpecReduce_1 113# happyReduction_354
+happyReduction_354 (HappyTerminal (T_type happy_var_1))
+	 =  HappyAbsSyn8
+		 (happy_var_1
+	)
+happyReduction_354 _  = notHappyAtAll 
+
+happyReduce_355 = happySpecReduce_1 114# happyReduction_355
+happyReduction_355 (HappyTerminal (T_id happy_var_1))
+	 =  HappyAbsSyn18
+		 ((Id happy_var_1)
+	)
+happyReduction_355 _  = notHappyAtAll 
+
+happyReduce_356 = happySpecReduce_1 115# happyReduction_356
+happyReduction_356 _
+	 =  HappyAbsSyn115
+		 (()
+	)
+
+happyReduce_357 = happySpecReduce_1 115# happyReduction_357
+happyReduction_357 _
+	 =  HappyAbsSyn115
+		 (()
+	)
+
+happyReduce_358 = happySpecReduce_0 116# happyReduction_358
+happyReduction_358  =  HappyAbsSyn115
+		 (()
+	)
+
+happyReduce_359 = happySpecReduce_1 116# happyReduction_359
+happyReduction_359 _
+	 =  HappyAbsSyn115
+		 (()
+	)
+
+happyNewToken action sts stk
+	= lexIDL(\tk -> 
+	let cont i = action i i tk (HappyState action) sts stk in
+	case tk of {
+	T_eof -> action 199# 199# (error "reading EOF!") (HappyState action) sts stk;
+	T_semi -> cont 117#;
+	T_module -> cont 118#;
+	T_interface -> cont 119#;
+	T_oparen -> cont 120#;
+	T_cparen -> cont 121#;
+	T_ocurly -> cont 122#;
+	T_ccurly -> cont 123#;
+	T_colon -> cont 124#;
+	T_comma -> cont 125#;
+	T_dot -> cont 126#;
+	T_dotdotdot -> cont 127#;
+	T_const -> cont 128#;
+	T_volatile -> cont 129#;
+	T_equal -> cont 130#;
+	T_eqeq -> cont 131#;
+	T_neq -> cont 132#;
+	T_or -> cont 133#;
+	T_rel_or -> cont 134#;
+	T_xor -> cont 135#;
+	T_and -> cont 136#;
+	T_rel_and -> cont 137#;
+	T_shift happy_dollar_dollar -> cont 138#;
+	T_div -> cont 139#;
+	T_mod -> cont 140#;
+	T_not -> cont 141#;
+	T_negate -> cont 142#;
+	T_question -> cont 143#;
+	T_typedef -> cont 144#;
+	T_extern -> cont 145#;
+	T_type happy_dollar_dollar -> cont 146#;
+	T_idl_type happy_dollar_dollar -> cont 147#;
+	T_float happy_dollar_dollar -> cont 148#;
+	(T_int Short) -> cont 149#;
+	(T_int Long) -> cont 150#;
+	(T_int LongLong) -> cont 151#;
+	(T_uint LongLong) -> cont 152#;
+	(T_int Natural) -> cont 153#;
+	T_unsigned -> cont 154#;
+	T_signed -> cont 155#;
+	T_char -> cont 156#;
+	T_wchar -> cont 157#;
+	T_struct -> cont 158#;
+	T_union -> cont 159#;
+	T_switch -> cont 160#;
+	T_case -> cont 161#;
+	T_default -> cont 162#;
+	T_enum -> cont 163#;
+	T_lt -> cont 164#;
+	T_le -> cont 165#;
+	T_gt -> cont 166#;
+	T_ge -> cont 167#;
+	T_osquare -> cont 168#;
+	T_csquare -> cont 169#;
+	T_sizeof -> cont 170#;
+	T_void -> cont 171#;
+	T_mode happy_dollar_dollar -> cont 172#;
+	T_literal happy_dollar_dollar -> cont 173#;
+	T_string_lit happy_dollar_dollar -> cont 174#;
+	T_callconv happy_dollar_dollar -> cont 175#;
+	T_id happy_dollar_dollar -> cont 176#;
+	T_dispinterface -> cont 177#;
+	T_coclass -> cont 178#;
+	T_library -> cont 179#;
+	T_plus -> cont 180#;
+	T_times -> cont 181#;
+	T_minus -> cont 182#;
+	T_string -> cont 183#;
+	T_wstring -> cont 184#;
+	T_methods -> cont 185#;
+	T_properties -> cont 186#;
+	T_cpp_quote -> cont 187#;
+	T_hs_quote -> cont 188#;
+	T_include happy_dollar_dollar -> cont 189#;
+	T_importlib -> cont 190#;
+	T_include_start happy_dollar_dollar -> cont 191#;
+	T_include_end -> cont 192#;
+	T_gnu_attribute -> cont 193#;
+	T_import -> cont 194#;
+	T_pragma happy_dollar_dollar -> cont 195#;
+	T_hdefine -> cont 196#;
+	T_safearray -> cont 197#;
+	T_unknown happy_dollar_dollar -> cont 198#;
+	_ -> happyError
+	})
+
+happyThen :: LexM a -> (a -> LexM b) -> LexM b
+happyThen = (thenLexM)
+happyReturn :: a -> LexM a
+happyReturn = (returnLexM)
+happyThen1 = happyThen
+happyReturn1 = happyReturn
+
+parseIDL = happyThen (happyParse action_0) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll })
+
+happySeq = happyDontSeq
+
+addTypes :: [Id] -> LexM ()
+addTypes ids = do
+  sequence (map addTypedef ls)
+  return ()
+ where
+  ls = map getName ids
+
+  getName (Id s) = s
+  getName (ArrayId i _) = getName i
+  getName (Pointed _ i) = getName i
+  getName (CConvId _ i) = getName i
+  getName (FunId i _ _) = getName i
+
+addIfaceTypedef :: String -> LexM Id
+addIfaceTypedef nm = addTypedef nm >> return (Id nm)
+
+mkBitField :: String -> Literal -> Int
+mkBitField nm l = 
+  case l of
+    IntegerLit (ILit _ i) -> fromInteger i
+    _ -> error ("bitfield " ++ show nm ++ " not an int.")
+
+warningMsg :: String -> LexM ()
+warningMsg msg = do
+  l <- getSrcLoc
+  ioToLexM (hPutStrLn stderr (show l ++ ": warning: "++msg))
+
+dumpErrMsg :: LexM ()
+dumpErrMsg = do
+ l   <- getSrcLoc
+ str <- getStream
+ ioToLexM (ioError (userError (show l ++ ": Parse error on input: " ++ takeWhile (/='\n') str)))
+
+happyError :: LexM a
+happyError = do
+ l   <- getSrcLoc
+ str <- getStream
+ ioToLexM (ioError (userError (show l ++ ": Parse error: " ++ takeWhile (/='\n') str)))
+{-# LINE 1 "GenericTemplate.hs" #-}
+-- Id: GenericTemplate.hs,v 1.24 2003/06/03 09:41:51 ross Exp 
+
+
+
+
+
+
+
+
+
+
+
+
+
+{-# LINE 27 "GenericTemplate.hs" #-}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+infixr 9 `HappyStk`
+data HappyStk a = HappyStk a (HappyStk a)
+
+-----------------------------------------------------------------------------
+-- starting the parse
+
+happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
+
+-----------------------------------------------------------------------------
+-- Accepting the parse
+
+happyAccept j tk st sts (HappyStk ans _) = (happyTcHack j 
+				                  )
+					   (happyReturn1 ans)
+
+-----------------------------------------------------------------------------
+-- Arrays only: do the next action
+
+{-# LINE 150 "GenericTemplate.hs" #-}
+
+
+-----------------------------------------------------------------------------
+-- HappyState data type (not arrays)
+
+
+
+newtype HappyState b c = HappyState
+        (Int# ->                    -- token number
+         Int# ->                    -- token number (yes, again)
+         b ->                           -- token semantic value
+         HappyState b c ->              -- current state
+         [HappyState b c] ->            -- state stack
+         c)
+
+
+
+-----------------------------------------------------------------------------
+-- Shifting a token
+
+happyShift new_state 1# tk st sts stk@(x `HappyStk` _) =
+     let i = (case x of { HappyErrorToken (I# (i)) -> i }) in
+--     trace "shifting the error token" $
+     new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)
+
+happyShift new_state i tk st sts stk =
+     happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)
+
+-- happyReduce is specialised for the common cases.
+
+happySpecReduce_0 i fn 1# tk st sts stk
+     = happyFail 1# tk st sts stk
+happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk
+     = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)
+
+happySpecReduce_1 i fn 1# tk st sts stk
+     = happyFail 1# tk st sts stk
+happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')
+     = let r = fn v1 in
+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))
+
+happySpecReduce_2 i fn 1# tk st sts stk
+     = happyFail 1# tk st sts stk
+happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')
+     = let r = fn v1 v2 in
+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))
+
+happySpecReduce_3 i fn 1# tk st sts stk
+     = happyFail 1# tk st sts stk
+happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
+     = let r = fn v1 v2 v3 in
+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))
+
+happyReduce k i fn 1# tk st sts stk
+     = happyFail 1# tk st sts stk
+happyReduce k nt fn j tk st sts stk
+     = case happyDrop (k -# (1# :: Int#)) sts of
+	 sts1@(((st1@(HappyState (action))):(_))) ->
+        	let r = fn stk in  -- it doesn't hurt to always seq here...
+       		happyDoSeq r (action nt j tk st1 sts1 r)
+
+happyMonadReduce k nt fn 1# tk st sts stk
+     = happyFail 1# tk st sts stk
+happyMonadReduce k nt fn j tk st sts stk =
+        happyThen1 (fn stk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))
+       where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))
+             drop_stk = happyDropStk k stk
+
+happyDrop 0# l = l
+happyDrop n ((_):(t)) = happyDrop (n -# (1# :: Int#)) t
+
+happyDropStk 0# l = l
+happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs
+
+-----------------------------------------------------------------------------
+-- Moving to a new state after a reduction
+
+
+
+
+
+
+
+
+
+happyGoto action j tk st = action j j tk (HappyState action)
+
+
+-----------------------------------------------------------------------------
+-- Error recovery (1# is the error token)
+
+-- parse error if we are in recovery and we fail again
+happyFail  1# tk old_st _ stk =
+--	trace "failing" $ 
+    	happyError
+
+
+{-  We don't need state discarding for our restricted implementation of
+    "error".  In fact, it can cause some bogus parses, so I've disabled it
+    for now --SDM
+
+-- discard a state
+happyFail  1# tk old_st (((HappyState (action))):(sts)) 
+						(saved_tok `HappyStk` _ `HappyStk` stk) =
+--	trace ("discarding state, depth " ++ show (length stk))  $
+	action 1# 1# tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))
+-}
+
+-- Enter error recovery: generate an error token,
+--                       save the old token and carry on.
+happyFail  i tk (HappyState (action)) sts stk =
+--      trace "entering error recovery" $
+	action 1# 1# tk (HappyState (action)) sts ( (HappyErrorToken (I# (i))) `HappyStk` stk)
+
+-- Internal happy errors:
+
+notHappyAtAll = error "Internal Happy error\n"
+
+-----------------------------------------------------------------------------
+-- Hack to get the typechecker to accept our action functions
+
+
+happyTcHack :: Int# -> a -> a
+happyTcHack x y = y
+{-# INLINE happyTcHack #-}
+
+
+-----------------------------------------------------------------------------
+-- Seq-ing.  If the --strict flag is given, then Happy emits 
+--	happySeq = happyDoSeq
+-- otherwise it emits
+-- 	happySeq = happyDontSeq
+
+happyDoSeq, happyDontSeq :: a -> b -> b
+happyDoSeq   a b = a `seq` b
+happyDontSeq a b = b
+
+-----------------------------------------------------------------------------
+-- Don't inline any functions from the template.  GHC has a nasty habit
+-- of deciding to inline happyGoto everywhere, which increases the size of
+-- the generated parser quite a bit.
+
+
+
+
+
+
+
+
+
+{-# NOINLINE happyShift #-}
+{-# NOINLINE happySpecReduce_0 #-}
+{-# NOINLINE happySpecReduce_1 #-}
+{-# NOINLINE happySpecReduce_2 #-}
+{-# NOINLINE happySpecReduce_3 #-}
+{-# NOINLINE happyReduce #-}
+{-# NOINLINE happyMonadReduce #-}
+{-# NOINLINE happyGoto #-}
+{-# NOINLINE happyFail #-}
+
+-- end of Happy Template.
+ src/Parser.y view
@@ -0,0 +1,805 @@+{
+{-
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+% @(#) $Docid: Jan. 15th 2004  10:33  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+A grammar for IDL, DCE / MS (IDL/ODL) style.
+
+Conflicts:
+   - 1 reduce/reduce conflict due to `default'
+     both being an attribute and a keyword.
+   - 7 shift/reduce conflicts due to the overloading
+     of `const' (t. qualifier and keyword.)
+
+ToDo: 
+  - fix above conflicts.
+
+-}
+module Parser ( parseIDL ) where
+ 
+import LexM
+import Lex
+import IDLToken
+import IDLSyn
+import IDLUtils ( mkFunId, mkMethodId, toCConvAttrib,
+                  mkGNUAttrib, toPackedAttrib, exprType )
+import BasicTypes
+import Literal
+import IO ( hPutStrLn, stderr )
+{-
+BEGIN_GHC_ONLY
+import GlaExts
+END_GHC_ONLY
+-}
+}
+
+%name parseIDL
+%tokentype { IDLToken }
+%monad { LexM } {thenLexM } { returnLexM }
+%lexer { lexIDL } { T_eof }
+%token
+	';'	      { T_semi }
+        MODULE	      { T_module }
+        INTERFACE     { T_interface }
+        '('           { T_oparen }
+        ')'           { T_cparen }
+        '{'           { T_ocurly }
+        '}'           { T_ccurly }
+        ':'           { T_colon  }
+        ','           { T_comma }
+        '.'           { T_dot }
+        '...'         { T_dotdotdot }
+        CONST         { T_const }
+        VOLATILE      { T_volatile }
+        '='           { T_equal }
+        '=='          { T_eqeq }
+        '!='          { T_neq }
+        '|'           { T_or }
+        '||'          { T_rel_or }
+        '^'           { T_xor }
+        '&'           { T_and }
+        '&&'          { T_rel_and }
+        SHIFT         { T_shift $$ }
+        '/'           { T_div }
+        '%'           { T_mod }
+        '~'           { T_not }
+        '!'           { T_negate }
+        '?'           { T_question }
+        TYPEDEF       { T_typedef }
+        EXTERN        { T_extern }
+        TYPE          { T_type $$ }
+	ITYPE         { T_idl_type $$ }
+        FLOAT         { T_float $$ }
+	SHORT         { (T_int Short) }
+	LONG          { (T_int Long) }
+	LONGLONG      { (T_int LongLong) }
+	ULONGLONG     { (T_uint LongLong) }
+        INT           { (T_int Natural) }
+        UNSIGNED      { T_unsigned }
+        SIGNED        { T_signed }
+        CHAR          { T_char }
+        WCHAR         { T_wchar }
+        STRUCT        { T_struct }
+        UNION         { T_union }
+        SWITCH        { T_switch }
+        CASE          { T_case }
+        DEFAULT       { T_default }
+        ENUM          { T_enum }
+        '<'           { T_lt }
+        '<='          { T_le }
+        '>'           { T_gt }
+        '>='          { T_ge }
+        '['           { T_osquare }
+        ']'           { T_csquare }
+        SIZEOF        { T_sizeof }
+        VOID          { T_void }
+        MODE          { T_mode $$ }
+        LITERAL       { T_literal $$ }
+        STRING_LIT    { T_string_lit $$ }
+	CALLCONV      { T_callconv $$ }
+	ID	      { T_id $$ }
+	DISPINTERFACE { T_dispinterface }
+	COCLASS       { T_coclass }
+	LIBRARY       { T_library }
+	'+'	      { T_plus }
+	'*'	      { T_times }
+	'-'	      { T_minus }
+	STRING        { T_string }
+	WSTRING       { T_wstring }
+	METHODS	      { T_methods }
+	PROPERTIES    { T_properties }
+	CPP_QUOTE     { T_cpp_quote }
+	HS_QUOTE      { T_hs_quote }
+	INCLUDE	      { T_include $$ }
+        IMPORTLIB     { T_importlib }
+        INCLUDE_START { T_include_start $$ }
+        INCLUDE_END   { T_include_end }
+	ATTRIBUTE     { T_gnu_attribute }
+        IMPORT        { T_import }
+	PRAGMA        { T_pragma $$ }
+        HDEFINE       { T_hdefine }
+	SAFEARRAY     { T_safearray }
+        UNKNOWN       { T_unknown $$ }
+%%
+
+{-
+ Share the same parser for DCE IDL input and ASFs. To avoid
+ running into gratuitous conflicts, ASF input is assumed to
+ be prefixed by a '=' (inserted by the compiler.)
+-}
+
+specification :: { Either [Defn] [(Name, Bool, [Attribute])] }
+   : definitions	     { Left  (reverse $1) }
+   | '=' attr_defs           { Right (reverse $2) }
+
+definitions  :: { [Defn] }
+   :                         {    []   }
+   | definitions definition  { $2 : $1 }
+
+attr_defs :: { [(String, Bool, [Attribute])] }
+   : {- empty -}             {    []   }
+   | attr_defs attr_def      { $2 : $1 }
+
+attr_def :: { (String, Bool, [Attribute] ) }
+   : attr_name ':' opt_attributes  { ($1, True, $3) }
+   | attr_name '=' opt_attributes  { ($1, False, $3) }
+
+attr_name :: { String }
+   : ID    { $1 }
+   | TYPE  { $1 }
+
+definition   :: { Defn }
+   : type_dcl      ';'            { $1 }
+   | DISPINTERFACE identifier ';' {% let (Id i) = $2 in addIfaceTypedef i >>= \ v -> return (Forward v) }
+   | attributed    semi           { $1 }
+   | cpp_quote     semi           { $1 }
+   | hs_quote      semi           { $1 }
+   | define                       { $1 }
+   | import_dcl    ';'            { $1 }
+   | pragma_dcl                   { $1 }
+
+attributed   :: { Defn }
+   : attributes attr_defn { Attributed $1 $2 }
+   | attr_defn            { $1 }
+
+attr_defn    :: { Defn }
+   : interface_dcl             {         $1 }
+   | MODULE identifier         { Forward $2 }
+   | MODULE identifier  '{' definitions semi '}'
+                               { Module $2 (reverse $4) }
+   | dispinterface             { $1 }
+   | COCLASS identifier '{' coclass_members ';' '}'
+                               {% let (Id i) = $2 in addIfaceTypedef i >>= \ v -> return (CoClass v (reverse $4)) }
+   | COCLASS TYPE '{' coclass_members ';' '}'
+                               { CoClass (Id $2) (reverse $4) }
+   | LIBRARY identifier '{' definitions '}'
+	                       { Library $2 (reverse $4) }
+   | op_decl                   { $1 }
+
+{- op_decls at the toplevel isn't legal, but we allow it to be parsed
+   anyhow, and report the presence of these later on -}
+
+dispinterface :: { Defn }
+   : dispinterface_hdr '{'
+       PROPERTIES ':' attr_id_list 
+       METHODS    ':' method_decls
+     '}'    {% let (Id i) = $1 in addIfaceTypedef i >>= \ v -> return (DispInterface v $5 (reverse $8)) }
+   | dispinterface_hdr '{' 
+       INTERFACE simple_declarator ';'
+     '}'    {% let (Id i) = $1 in addIfaceTypedef i >>= \ v -> return (DispInterfaceDecl v $4) }
+
+attr_id_list  :: { [([Attribute], Type, Id)] }
+   : {- empty -} 			            { [] } 
+   | attr_id_list opt_attributes type_spec declarator ';' { ($2,$3,$4):$1 }
+
+coclass_members :: { [CoClassMember] }
+   : coclass_member 		        {   [$1]  }
+   | coclass_members ';' coclass_member { $3 : $1 }
+
+coclass_member  :: { CoClassMember }
+   : opt_coclass_attrs INTERFACE TYPE           { (True,  Id $3, $1) }
+   | opt_coclass_attrs DISPINTERFACE TYPE       { (False, Id $3, $1) }
+   | opt_coclass_attrs INTERFACE identifier     { (True,  $3, $1) }
+   | opt_coclass_attrs DISPINTERFACE identifier { (False, $3, $1) }
+
+opt_coclass_attrs :: { [Attribute] }
+   : {- empty -}                   {  [] }
+   | '[' cc_attributes ']'         {  $2 }
+
+interface_dcl :: { Defn }
+   : interface_hdr { Forward $1 }
+   | interface_hdr inheritance_spec '{' exports '}' 
+       { Interface $1 $2 (reverse $4) }
+
+{- 
+  We eagerly add the name of an interface as a type name, so
+  that typedefs inside the interface body can refer to it.
+-}
+
+interface_hdr :: { Id }
+   : INTERFACE identifier {% let (Id i) = $2 in addIfaceTypedef i >>= return  }
+   | INTERFACE TYPE       { (Id $2) }
+   | INTERFACE ITYPE      { (Id "Object") }
+
+dispinterface_hdr :: { Id }
+   : DISPINTERFACE identifier {% let (Id i) = $2 in addIfaceTypedef i >>= return  }
+   | DISPINTERFACE TYPE       { (Id $2) }
+
+cpp_quote  :: { Defn }
+   : CPP_QUOTE '(' STRING_LIT ')' { CppQuote $3 }
+
+hs_quote  :: { Defn }
+   : HS_QUOTE '(' STRING_LIT ')' { HsQuote $3 }
+   | INCLUDE  			 { CInclude $1 }
+
+exports   :: { [Defn] }
+   : {-empty -}      {    []   }
+   | exports export  { $2 : $1 }
+
+
+export    :: { Defn }
+   :  attributed_exp  ';' { $1 }
+   |  type_dcl   ';'      { $1 }
+   |  cpp_quote semi      { $1 }
+   |  hs_quote  semi      { $1 }
+   |  import_dcl ';'      { $1 }
+
+attributed_exp :: { Defn }
+   : attributes op_decl  { Attributed $1 $2 }
+   | op_decl             { $1 }
+
+inheritance_spec :: { Inherit }
+   : 	            { [] }
+   | ':' TYPE       { [ $2 ]  }
+   | ':' identifier { let (Id i) = $2 in [ i ]  }
+
+import_dcl     :: { Defn }
+   : IMPORT string_lit_list       {% slurpImports (parseIDL >>= \ (Left y) -> return y) $2 }
+   | IMPORTLIB '(' STRING_LIT ')' {% handleImportLib (parseIDL >>= \ (Left y) -> return y) $3 }
+
+{- No validation here of what's on the #pragma line -}
+pragma_dcl  :: { Defn }
+   : PRAGMA 		       { Pragma $1 }
+   | INCLUDE_START	       { IncludeStart $1 }
+   | INCLUDE_END               { IncludeEnd }
+   
+define :: { Defn }
+   : HDEFINE ID const_expr     { Constant (Id $2) [] (exprType (TyInteger Natural) $3) $3 }
+
+string_lit_list :: { [String] }
+   : STRING_LIT			  { [ $1 ] }
+   | STRING_LIT ',' string_lit_list { ($1 : $3) }
+
+{- 
+ Not using type_spec for constant types minimises
+ the shift/reduce conflicts (i.e., no CONST qualifiers
+ allowed below.)
+-}
+const_type    :: { Type }
+   : integer_ty         { $1 }
+   | CHAR               { TyChar  }
+   | WCHAR              { TyWChar }
+   | FLOAT              { TyFloat $1 } 
+   | VOID		{ TyVoid }
+   | VOID '*'           { TyPointer TyVoid }
+   | CHAR '*'           { TyString Nothing }
+   | WCHAR '*'          { TyWString Nothing }
+   | string_type        { $1 }
+   | const_type '[' ']' { TyArray $1 [] }
+     -- my word, what junk C allows here.
+   | SIGNED               { TySigned True  }
+   | UNSIGNED             { TySigned False }
+   | UNSIGNED integer_ty        { TyApply (TySigned False) $2 }
+   | SIGNED   integer_ty        { TyApply (TySigned True)  $2 }
+   | UNSIGNED CHAR        { TyApply (TySigned False) TyChar }
+   | integer SIGNED INT   { TyApply (TySigned True)  $1 }
+   | integer UNSIGNED INT { TyApply (TySigned False) $1 }
+   | SIGNED CHAR        { TyApply (TySigned True)  TyChar }
+   | ID                 { TyName $1 Nothing }
+   | TYPE               { TyName $1 Nothing }
+   | TYPE '*'           { TyPointer (TyName $1 Nothing) }
+   | ITYPE		{ $1 }
+   | error              {% dumpErrMsg >> return TyVoid }
+
+integer :: { Type }
+   : SHORT      { TyInteger Short }
+   | LONG       { TyInteger Long  }
+   | LONG LONG  { TyInteger LongLong }
+   | LONGLONG   { TyInteger LongLong }
+   | ULONGLONG  { TyApply (TySigned False) (TyInteger LongLong) }
+
+integer_ty :: { Type }
+   : integer      { $1 }
+   | integer INT  { $1 }
+   | INT          { TyInteger Natural }
+
+const_type_cast    :: { Type }
+   : integer_ty         { $1 }
+   | CHAR               { TyChar  }
+   | WCHAR              { TyWChar }
+   | FLOAT              { TyFloat $1 } 
+   | VOID		{ TyVoid }
+   | string_type        { $1 }
+   | const_type '[' ']' { TyArray $1 [] }
+   | SIGNED               { TySigned True  }
+   | UNSIGNED           { TySigned False }
+   | UNSIGNED integer_ty        { TyApply (TySigned False) $2 }
+   | SIGNED integer_ty    { TyApply (TySigned True)  $2 }
+   | integer UNSIGNED INT { TyApply (TySigned False) $1 }
+   | integer SIGNED INT   { TyApply (TySigned True)  $1 }
+   | UNSIGNED CHAR        { TyApply (TySigned False) TyChar }
+   | SIGNED CHAR          { TyApply (TySigned True)  TyChar }
+   | TYPE                 { TyName $1 Nothing }
+   | ITYPE		  { $1 }
+   | error                {% dumpErrMsg >> return TyVoid }
+
+const_expr    :: { Expr }
+   : cond_expr	 { $1 }
+
+cond_expr     :: { Expr }
+   : log_or_expr		              { $1 }
+   | cond_expr '?' const_expr ':' log_or_expr { Cond $1 $3 $5 }
+
+log_or_expr   :: { Expr }
+   : log_and_expr			{ $1 }
+   | log_or_expr '||' log_and_expr	{ Binary LogOr $1 $3 }
+   
+log_and_expr  :: { Expr }
+   : or_expr			 { $1 }
+   | log_and_expr '&&' or_expr   { Binary LogAnd $1 $3 }
+
+or_expr     :: { Expr }
+   : xor_expr	           { $1 }
+   | or_expr '|' xor_expr  { Binary Or $1 $3 }
+
+xor_expr      :: { Expr }
+   : and_expr	           { $1 }
+   | xor_expr '^' and_expr { Binary Xor $1 $3 }
+
+and_expr      :: { Expr }
+   : eq_expr		  { $1 }
+   | and_expr '&' eq_expr { Binary And $1 $3 }
+
+eq_expr       :: { Expr }
+   : rel_expr			{ $1 }
+   | eq_expr eq_op rel_expr	{ Binary Eq $1 $3 }
+
+eq_op :: { BinaryOp }
+   : '=='  { Eq }
+   | '!='  { Ne }
+
+rel_expr      :: { Expr }
+   : shift_expr			{ $1 }
+   | rel_expr '<'  shift_expr   { Binary Lt $1 $3 }
+   | rel_expr '<=' shift_expr   { Binary Le $1 $3 }
+   | rel_expr '>=' shift_expr   { Binary Ge $1 $3 }
+   | rel_expr '>'  shift_expr   { Binary Gt $1 $3 }
+
+shift_expr    :: { Expr }
+   : add_expr		    { $1 }
+   | shift_expr SHIFT add_expr  { Binary (Shift $2) $1 $3 }
+
+add_expr      :: { Expr }
+   : mult_expr		 { $1 }
+   | add_expr '+' mult_expr  { Binary Add $1 $3 }
+   | add_expr '-' mult_expr  { Binary Sub $1 $3 }
+
+mult_expr     :: { Expr }
+   : cast_expr	         { $1 }
+   | mult_expr '*' cast_expr { Binary Mul $1 $3 }
+   | mult_expr '/' cast_expr { Binary Div $1 $3 }
+   | mult_expr '%' cast_expr { Binary Mod $1 $3 }
+
+cast_expr     :: { Expr }
+   : unary_expr		      { $1 }
+   | '(' const_type_cast ')' cast_expr { Cast $2 $4 }
+
+unary_expr    :: { Expr }
+   : primary_expr  	          { $1 }
+   | SIZEOF '(' const_type ')'    { Sizeof $3 }
+   | unary_operator primary_expr  { Unary $1 $2}
+
+unary_operator :: { UnaryOp }
+   : '-' { Minus } | '+' { Plus } | '~' { Not } | '!' { Negate }
+
+primary_expr  :: { Expr }
+   : identifier  	 { let (Id i) = $1 in Var i }
+   | LITERAL	         { Lit $1 }
+   | STRING_LIT	         { Lit (StringLit $1) }
+   | '(' const_expr ')'  { $2 }
+
+type_dcl      :: { Defn }
+   : mb_gnu_attributes TYPEDEF opt_attributes type_spec declarators mb_gnu_attributes 
+     {% let decls = reverse $5 in addTypes decls >> return (Typedef $4 $3 decls) }
+
+   | attributes struct_or_union_or_enum_spec               { Attributed $1 (TypeDecl $2) }
+   | struct_or_union_or_enum_spec 		           { TypeDecl $1 }
+   | attributes CONST const_type identifier '=' const_expr { Constant $4 $1 $3 $6 }
+   | CONST const_type identifier '=' const_expr            { Constant $3 [] $2 $5 }
+   | mb_gnu_attributes EXTERN mb_gnu_attributes type_spec declarators mb_gnu_attributes
+     {% let decls = reverse $5 in addTypes decls >> return (ExternDecl $4 decls) }
+
+type_spec     :: { Type }
+   : type_specifier                { $1 }
+   | type_spec '[' ']'             { TyArray $1 [] }
+   | type_spec '[' const_expr ']'  { TyArray $1 [$3] }
+   | type_specifier type_qualifier { TyApply (TyQualifier $2) $1 }
+   | type_qualifier type_spec      { TyApply (TyQualifier $1) $2 }
+
+type_spec_no_leading_qual :: { Type }
+   : type_specifier		       { $1 }
+   | type_spec_no_leading_qual '[' ']' { TyArray $1 [] }
+   | type_specifier type_qualifier     { TyApply (TyQualifier $2) $1 }
+
+type_qualifier  :: { Qualifier }
+   : CONST     { Const    }
+   | VOLATILE  { Volatile }
+
+type_specifier  :: { Type }
+   : FLOAT                { TyFloat $1 }
+   | CHAR                 { TyChar  }
+   | WCHAR                { TyWChar }
+   | integer_ty           { $1 }
+   | VOID                 { TyVoid }
+   | SIGNED               { TySigned True  }
+   | UNSIGNED             { TySigned False }
+   | SIGNED signed_type_specifier          { TyApply (TySigned True) $2  }
+   | SIGNED CONST signed_type_specifier    { TyApply (TySigned True) $3  }
+   | UNSIGNED signed_type_specifier        { TyApply (TySigned False) $2 }
+   | UNSIGNED CONST signed_type_specifier  { TyApply (TySigned False) $3 }
+   | integer SIGNED INT   { TyApply (TySigned True)  $1 }
+   | integer UNSIGNED INT { TyApply (TySigned False) $1 }
+   | ID                   { TyName $1 Nothing } 
+   | TYPE                 { TyName $1 Nothing } 
+   | ITYPE		{ $1 }
+   | SAFEARRAY safearray_type_spec ')' { TySafeArray $2 }  {- the oparen is part of the SAFEARRAY lexeme..-}
+   | struct_or_union_spec { $1 }
+   | enum_type            { $1 }
+   | error                {% dumpErrMsg >> return TyVoid }
+
+signed_type_specifier :: { Type }
+                      : integer_ty   { $1 }
+		      | CHAR         { TyChar }
+		      | FLOAT        { TyFloat $1 }
+--		      | ID           { TyName $1 Nothing }
+		      | TYPE         { TyName $1 Nothing }
+   		      | ITYPE	     { $1 }
+
+
+safearray_type_spec :: { Type }
+         : type_specifier  { $1 }
+	 | safearray_type_spec '*' { TyPointer $1 }
+
+struct_or_union_or_enum_spec :: { Type }
+     : struct_or_union_spec  { $1 }
+     | enum_type	     { $1 }
+
+struct_or_union_spec :: { Type }
+     : struct_type      { $1 }
+     | union_type       { $1 }
+
+struct_type :: { Type }
+     : STRUCT simple_declarator '{' member_list '}' mb_gnu_attributes { TyStruct (Just $2) (reverse $4) (toPackedAttrib $6) }
+     | STRUCT            '{' member_list '}'        mb_gnu_attributes { TyStruct Nothing (reverse $3) (toPackedAttrib $5) }
+     | STRUCT simple_declarator                     { TyStruct (Just $2) [] Nothing }
+              
+
+union_type           :: { Type }
+     : UNION switch_id SWITCH  '(' switch_type_spec identifier ')' 
+       switch_id '{' switch_body  '}' { TyUnion $2 $5 $6 $8 (reverse $10) }
+
+     | UNION switch_id  '{' member_or_switch_list '}' mb_gnu_attributes
+                        { case $4 of { Left sw -> TyUnionNon $2 (reverse sw) ; Right mem -> TyCUnion $2 (reverse mem) (toPackedAttrib $6) } }
+     | UNION identifier mb_gnu_attributes { TyCUnion (Just $2) [] (toPackedAttrib $3) }
+
+member_or_switch_list :: { Either [Switch] [Member] }
+     : switch_body       { Left $1 }
+     | member_list       { Right $1 }
+
+declarators        :: { [ Id ] }
+     : declarator		  { [ $1 ]  }
+     | declarators ',' declarator { $3 : $1 }
+
+declarator :: { Id }
+     : callconv_or_attr pointer_declarator  { $1 $2 }
+     | pointer_declarator           { $1 }
+     | callconv_or_attr direct_declarator   { $1 $2 }
+     | direct_declarator            { $1 }
+
+callconv_or_attr :: { (Id -> Id) }
+     : gnu_attributes    { toCConvAttrib $1 }
+     | CALLCONV          { CConvId $1 }
+
+direct_declarator :: { Id }
+     : simple_declarator          { $1 }
+     | '(' declarator ')'         { $2 }
+     | function_declarator        { $1 }
+     | array_declarator           { $1 }
+
+simple_declarator :: { Id }
+     : identifier	       { $1 }
+         -- bit field info is currently thrown away. ToDo: fix.
+     | identifier ':' LITERAL  { (let { (Id nm) = $1 ; x = mkBitField nm $3 } in BitFieldId x $1) }
+     | TYPE ':' LITERAL        { (let x = mkBitField $1 $3 in BitFieldId x (Id $1)) }
+     | ':' LITERAL             { (let x = mkBitField "" $2 in BitFieldId x (Id "")) }
+     | TYPE                    { (Id $1) }
+     | MODE                    { (if $1 == In then Id "in" else Id "out") }
+
+pointer_declarator :: { Id }
+     : pointer direct_declarator {  Pointed $1 $2 }
+     | pointer CALLCONV direct_declarator {  Pointed $1 (CConvId $2 $3) }
+     | pointer gnu_attributes direct_declarator {  Pointed $1 (toCConvAttrib $2 $3) }
+
+array_declarator :: { Id }
+     : direct_declarator '[' ']'             { ArrayId $1 []   } 
+     | direct_declarator '[' '*' ']'         { ArrayId $1 []   }
+     | direct_declarator '[' const_expr ']'  { ArrayId $1 [$3] }
+     | direct_declarator '[' primary_expr '.' '.' primary_expr ']'  { ArrayId $1 [$3,$6] }
+
+function_declarator :: { Id }
+     : direct_declarator '(' param_type_spec_list ')' { mkFunId $1 (reverse $3) }
+     | direct_declarator '(' ')'		      { mkFunId $1 [] }
+
+pointer  :: { [[Qualifier]] }
+     : '*'		      {   [[]]  }
+     | '*' type_quals 	      {   [$2]  }
+     | '*' pointer            { [] : $2 }
+     | '*' type_quals pointer { $2 : $3 }
+
+
+{- Storage qualifiers on pointers -}
+
+type_quals   :: { [ Qualifier ] }
+     : type_qualifier	          { [$1] }
+     | type_quals type_qualifier  { $2 : $1 }
+
+
+member_list  :: { [Member] }
+     : member mb_gnu_attributes ';'             { [ $1 ]  }
+     | member_list member mb_gnu_attributes ';' { $2 : $1 }
+
+member    :: { Member  }
+     : opt_attributes type_spec declarators { ($2, $1, reverse $3) }
+     | opt_attributes type_spec             { ($2, $1, []) }
+     -- The last one is unpleasant, unnamed members.
+
+switch_id	 :: { Maybe Id }
+     : 			{ Nothing }
+     | identifier	{ Just $1 }
+
+switch_type_spec :: { Type }
+     : integer_ty           { $1 }
+     | CHAR	            { TyChar }
+     | enum_type	    { $1 }
+     | struct_or_union_spec { $1 }
+     | ID                   { TyName $1 Nothing }
+     | TYPE                 { TyName $1 Nothing }
+
+switch_body      :: { [Switch] }
+     : case ';'			{ [ $1 ]  }
+     | switch_body case ';'	{ $2 : $1 }
+
+case	 :: { Switch }
+     : case_labels switch_arm          { Switch  $1  $2 }
+     | '[' case_label1 ']' switch1_arm { Switch [$2] $4 }
+
+switch1_arm  :: { Maybe SwitchArm }
+     : {- empty -} 	    { Nothing }
+     | type_spec declarator { Just (Param $2 $1 []) }
+     | type_spec            { Just (Param (Id "") $1 []) }
+
+switch_arm  :: { Maybe SwitchArm }
+     : {- empty -} 			   { Nothing }
+     | opt_attributes type_spec declarator { Just (Param $3 $2 $1) }
+     | opt_attributes type_spec            { Just (Param (Id "") $2 $1) }
+
+case_labels      :: { [CaseLabel] }
+     : case_label	      { [ $1 ] }
+     | case_labels case_label { $2 : $1 }
+
+case_label	 :: { CaseLabel }
+     : CASE const_expr ':' { Case [$2] }
+     | DEFAULT ':'   	   { Default }
+
+case_label1	 :: { CaseLabel }
+     : CASE '(' const_expr_list ')' { Case (reverse $3) }
+     | DEFAULT                      { Default }
+
+const_expr_list  :: { [Expr] }
+     : const_expr		      { [ $1 ]  }
+     | const_expr_list ',' const_expr { $3 : $1 }
+
+expr_list :: { [Expr] }
+     : {- empty -}      { [] }
+     | const_expr_list  { $1 }
+
+enum_type	 :: { Type }
+   : ENUM '{' enumerators opt_comma '}' { TyEnum Nothing (reverse $3) }
+   | ENUM identifier '{' 
+          enumerators opt_comma
+     '}'                    { TyEnum (Just $2) (reverse $4) }
+   | ENUM identifier        { TyEnum (Just $2) [] }
+
+{- NOTE: MIDL does allow a comma trailing the enumerator list -}
+enumerators      :: { [(Id, [Attribute], Maybe Expr)] }
+   : enumerator	                { [ $1 ]  }
+   | enumerators ',' enumerator { $3 : $1 }
+
+enumerator  :: { (Id, [Attribute], Maybe Expr) }
+   : identifier	                           { ($1, [], Nothing) } 
+   | attributes identifier                 { ($2, $1, Nothing) } 
+   | identifier '=' const_expr             { ($1, [], Just $3) }
+   | attributes identifier '=' const_expr  { ($2, $1, Just $4) }
+
+string_type :: { Type }
+   : string_or_wstring '<' shift_expr '>' { $1 (Just $3) }
+   | string_or_wstring		          { $1 Nothing   }
+
+string_or_wstring :: { (Maybe Expr -> Type) }
+   : STRING         { TyString  }
+   | WSTRING        { TyWString }
+
+method_decls :: { [Defn] }
+   : {- empty -}	          {    []   }
+   | method_decls method_decl ';' { $2 : $1 }
+
+method_decl  :: { Defn }
+   : opt_attributes op_type_spec declarator mb_gnu_attributes
+      { let m_id = mkMethodId $3 in (Attributed $1 (Operation m_id $2 Nothing Nothing)) }
+
+op_decl	     :: { Defn }
+--   : op_type_spec declarator { Operation $2 $1 Nothing Nothing }
+    : op_type_spec declarator mb_gnu_attributes { let m_id = mkMethodId $2 in (Operation m_id $1 Nothing Nothing) }
+
+
+opt_attributes   :: { [Attribute] }
+    : opt_attributes1  { concat $1 }
+
+opt_attributes1  :: { [[Attribute]] }
+    : {- empty -} { [] }
+    | attributes opt_attributes1 { $1 : $2 }
+
+attributes       :: { [Attribute] }
+    : '[' ']'                       {  []          }
+    | '[' attributes1 opt_comma ']' { (reverse $2) }
+
+attributes1      :: { [Attribute] }
+    : attribute                 {  [ $1 ] }
+    | attributes1 ',' attribute { $3 : $1 }
+
+attribute        :: { Attribute }
+    : identifier opt_attr_params   { Attrib $1 $2 }
+    | STRING		           { Attrib (Id "string") [] }
+    | MODE		           { Mode $1 }
+
+cc_attributes     :: { [Attribute] }
+    : cc_attribute                   {  [ $1 ] }
+    | cc_attributes ',' cc_attribute { $3 : $1 }
+
+cc_attribute        :: { Attribute }
+    : identifier                   { Attrib $1 [] }
+    | DEFAULT			   { Attrib (Id "default") [] }
+
+opt_attr_params  :: { [AttrParam] }
+    : {- empty -}	    { [] }
+    | '(' attr_params ')'   { (reverse $2) }
+
+attr_params	 :: { [AttrParam] }
+    : attr_param		 {   [$1] }
+    | attr_params ',' attr_param {  $3:$1 }
+
+attr_param	:: { AttrParam }
+    : const_expr		      { (AttrExpr $1) }
+    | {-empty-}			      { EmptyAttr }
+    | TYPE			      { (AttrLit (TypeConst $1)) }
+    | UNSIGNED TYPE                   { (AttrLit (TypeConst ("unsigned " ++ $2))) }
+    | SIGNED TYPE                     { (AttrLit (TypeConst ("signed " ++ $2))) }
+    | '{' LITERAL '}'                 { AttrLit $2 }  {- just a guid here, please! -}
+    | '*' attr_param		      { (AttrPtr $2)  }
+    
+op_type_spec   :: { Type }
+    : type_spec_no_leading_qual    { $1 }
+    | string_type                  { $1 }
+
+param_decl :: { Param }
+    : opt_attributes type_spec                      { Param (Id "") $2 $1 }
+    | opt_attributes type_spec declarator           { Param $3 $2 $1  }
+    | opt_attributes type_spec abstract_declarator  { Param $3 $2 $1  }
+    | '...'				            { Param (Id "vararg") TyVoid [] }
+
+param_type_spec_list :: { [Param] }
+    : param_decl 	                  { [$1]  }
+    | param_type_spec_list ',' param_decl { $3 : $1 }
+
+abstract_declarator :: { Id }
+    : pointer                               { Pointed $1 (Id "") }
+    | callconv_or_attr abstract_declarator  { $1 $2 }
+    | direct_abstract_declarator            { $1 }
+    | pointer direct_abstract_declarator    { Pointed $1 $2 }
+
+direct_abstract_declarator :: { Id }
+    : '(' abstract_declarator ')'        { $2 }
+    | '(' ')'                            { FunId (Id "") Nothing [] }
+    | '(' param_type_spec_list ')'       { FunId (Id "") Nothing $2 }
+    | direct_abstract_declarator '(' ')' { FunId $1 Nothing [] }
+    | direct_abstract_declarator '(' param_type_spec_list ')' { FunId $1 Nothing $3 }
+
+mb_gnu_attributes :: { [GNUAttrib] }
+    : {- empty -}    { [] }
+    | gnu_attributes { (reverse $1) }
+
+gnu_attributes :: { [GNUAttrib] }
+    : gnu_attribute                {   [$1]  }
+    | gnu_attributes gnu_attribute { ($2:$1) }
+
+gnu_attribute :: { GNUAttrib }
+    : ATTRIBUTE '(' '(' gnu_attrib ')' ')' { $4 }
+
+gnu_attrib :: { GNUAttrib }
+    : a_word            { mkGNUAttrib $1 [] }
+    | CALLCONV          { CConv $1 }
+    | a_word '(' ID ')' { mkGNUAttrib $1 [Var $3] }
+    | a_word '(' ID ',' const_expr_list ')' { mkGNUAttrib $1 (Var $3:$5) }
+
+a_word :: { String }
+    : ID     { $1 }
+    | TYPE   { $1 }
+
+identifier :: { Id }
+    : ID   { (Id $1) }
+    
+semi ::     { () }
+    : error { () }
+    | ';'   { () }
+
+opt_comma ::      { () }
+    : {- empty -} { () }
+    | ','         { () }
+
+{------------------ END OF GRAMMAR --------------}
+
+{
+
+addTypes :: [Id] -> LexM ()
+addTypes ids = do
+  sequence (map addTypedef ls)
+  return ()
+ where
+  ls = map getName ids
+
+  getName (Id s) = s
+  getName (ArrayId i _) = getName i
+  getName (Pointed _ i) = getName i
+  getName (CConvId _ i) = getName i
+  getName (FunId i _ _) = getName i
+
+addIfaceTypedef :: String -> LexM Id
+addIfaceTypedef nm = addTypedef nm >> return (Id nm)
+
+mkBitField :: String -> Literal -> Int
+mkBitField nm l = 
+  case l of
+    IntegerLit (ILit _ i) -> fromInteger i
+    _ -> error ("bitfield " ++ show nm ++ " not an int.")
+
+warningMsg :: String -> LexM ()
+warningMsg msg = do
+  l <- getSrcLoc
+  ioToLexM (hPutStrLn stderr (show l ++ ": warning: "++msg))
+
+dumpErrMsg :: LexM ()
+dumpErrMsg = do
+ l   <- getSrcLoc
+ str <- getStream
+ ioToLexM (ioError (userError (show l ++ ": Parse error on input: " ++ takeWhile (/='\n') str)))
+
+happyError :: LexM a
+happyError = do
+ l   <- getSrcLoc
+ str <- getStream
+ ioToLexM (ioError (userError (show l ++ ": Parse error: " ++ takeWhile (/='\n') str)))
+}
+ src/PpAbstractH.lhs view
@@ -0,0 +1,711 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Mar. 31th 2003  08:36  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Converting the data representing Haskell programs into source
+form. 
+
+Apart from the pretty printing of the data constructors of
+the various data types representing Haskell constructs (see
+@AbstractH.lhs@), this module also performs the following
+tasks:
+
+ - if the user requested that names shouldn't be qualified,
+   obey this when outputting VarNames.
+ - choose the right FFI to do call-outs (and call-ins). The
+   options (all controllable from the command line) are one
+   of: "new FFI", ghc FFI, or GreenCard stubs.
+
+\begin{code}
+module PpAbstractH 
+	(
+          ppHTopDecls
+	, ppType
+	, showAbstractH
+	, ppExpr
+	) where
+
+import PP hiding ( integer )
+import AbstractH
+import AbsHUtils ( splitFunTys, isVarPat, tyInt32 )
+import Opts	 ( optGreenCard, optTargetGhc, optNoQualNames
+		 , optNoOutput, optNoModuleHeader, optNoImports
+		 , optQualInstanceMethods, optHugs
+		 , optUnsafeCalls, optNoDllName
+		 , optPatternAsLambda
+		 , optLongLongIsInteger
+		 )
+import Literal
+import BasicTypes
+import Char  ( isAlpha )
+import Utils ( notNull )
+import LibUtils
+
+\end{code}
+
+\begin{code}
+type AbsHDoc a = PPDoc a
+
+showAbstractH :: AbsHDoc a -> String
+showAbstractH ad = showPPDoc ad undefined
+\end{code}
+
+
+\begin{code}
+ppHTopDecls :: [HTopDecl] -> AbsHDoc a
+ppHTopDecls ls = vcat (map ppHTopDecl ls)
+
+ppHTopDecl :: HTopDecl -> AbsHDoc a
+ppHTopDecl (HMod hm)    = ppHModule hm
+ppHTopDecl (HLit s)     = text s
+ppHTopDecl (CLit _)     = empty
+ppHTopDecl (HInclude s) 
+  | optGreenCard = text "%include" <+> text s
+     -- Only GHC understands this pragma, but its presence shouldn't
+     -- seriously offend anyone else...
+  | otherwise    = text "{-# OPTIONS -#include" <+> text str <+> text "#-}"
+ where
+   -- make sure we escape those double quotes.
+  str = 
+   case s of
+     '<':_ -> s
+     '"':_ -> s
+     _     -> show s
+
+\end{code}
+
+\begin{code}
+ppHModule :: HModule -> AbsHDoc a
+ppHModule (HModule nm flg exports imports decls) =
+ (if optNoModuleHeader then
+     empty
+  else
+     (case exports of
+       [] -> text "module" <+> ppName nm <+> text "where" $$ text ""
+       _  -> 
+         hang (text "module" <+> ppName nm)
+          7   (vsep (zipWith (\ x y -> x <+> ppExport y)
+			     (char '(':repeat comma) --)
+			     exports)      $$
+	       text ") where" $$ text ""))) $$
+ (if optNoImports then
+     empty
+  else     
+     vsep (map ppImport imports')) $$ 
+ text ""	    $$
+ ppHDecl decls      $$
+ if (optHugs && flg) then text "needPrims_hugs 4" else text ""
+ where
+  generateGreenCard = not optNoOutput && optGreenCard
+
+  imports'
+   | not generateGreenCard = imports
+   | otherwise             = ((HImport False Nothing ("StdDIS") Nothing):imports)
+
+
+ppExport :: HExport -> AbsHDoc a
+ppExport (HExport expo comment) = ppIEEntity expo <+> ppComment comment
+  where
+   -- one-line comment
+   ppComment Nothing   = empty
+   ppComment (Just c)  = text "--" <+> text c
+
+ppIEEntity :: HIEEntity -> AbsHDoc a
+ppIEEntity (IEModule nm)     = text "module" <+> ppName nm 
+ppIEEntity (IEVal nm)        = ppName nm
+ppIEEntity (IEClass c)       = ppName c
+ppIEEntity (IEType nm isAbs) = ppName nm <> if isAbs then empty else text "(..)"
+
+ppImport :: HImport -> AbsHDoc a
+ppImport (HImport qual as_name nm stuff) =
+ text "import" <+>
+ (if qual && not optNoQualNames then text "qualified" else empty) <+>
+ (case as_name of { Nothing -> empty ; Just a -> text "as" <+> ppName a} ) <+>
+ ppName nm <+>
+ case stuff of
+   Nothing -> empty
+   Just ls -> parens (fcat (punctuate (text ", ") (map ppIEEntity ls)))
+\end{code}
+
+\begin{code}
+ppHDecl :: HDecl -> AbsHDoc a
+ppHDecl (AndDecl d1 d2) = ppHDecl d1 $$ ppHDecl d2
+ppHDecl (TypeSig i mb_ctxt t) =
+  ppName i <+> vcat pp_sig
+
+{- One-line style:
+  ppName i <+> text "::" <+> 
+  (case mb_ctxt of
+    Nothing -> empty
+    Just ct -> ppContext True ct) <+>
+  ppType t
+-}
+
+ where
+  (args,res)  = splitFunTys t
+
+  pp_tys = pp_ctxt (map ppFunType (args ++ [res]))
+  pp_sig = zipWith (<+>) seps pp_tys
+
+  pp_ctxt rest = 
+    case mb_ctxt of
+      Nothing -> rest
+      Just x  -> ppContext False x : rest
+
+  seps = 
+    text "::" : 
+    case mb_ctxt of
+      Nothing -> arrows
+      Just _  -> text "=>" : arrows
+    
+  arrows = text "->" : arrows
+
+ppHDecl (ValDecl i [p1,p2] ges)
+ | isOpName i
+ = (ppPat p1 <+> ppValName i <+> ppPat p2) $$
+   (nest 2 (ppGuardedExprs ges)) $$
+   text ""
+
+ppHDecl (ValDecl i pats [g])
+  | isSimple g = sep [ppValName i <+> pp_pats, nest 2 (ppGuardedExpr (char '=') g)] $$
+                 text ""
+  | otherwise  = hang (ppValName i <+> pp_pats)
+		  2   (ppGuardedExpr (char '=') g) $$
+		 text ""
+  where
+    shufflePats = optPatternAsLambda && all isVarPat pats 
+    pp_pats
+     | shufflePats = equals <+> hsep (map (\ x -> char '\\' <+> ppPat x <+> text "->") pats)
+     | otherwise   = hsep (map ppPat pats) <+> equals
+
+    isSimple (GExpr _ (Bind  _ _ _)) = False
+    isSimple (GExpr _ (Bind_   _ _)) = False
+    isSimple (GExpr _ (Let     _ _)) = False
+    isSimple _			     = True
+
+ppHDecl (ValDecl i pats ges) =
+  (ppValName i <+> hsep (map ppPat pats)) $$
+  (nest 2 (ppGuardedExprs ges)) $$
+  text ""
+
+ppHDecl (Primitive safe cconv (dllname,_,fun,_) i t has_structs _ _)
+ | optTargetGhc   = -- GHC specific
+    (ppName i <+> text "::" <+>  ppType t) $$ 
+    ppName i <+> hsep arg_names <+> equals <+> text "_ccall_" <+> hsep (text fun:arg_names)
+ | optGreenCard = -- GreenCard output
+    (text "%fun"  <+> ppName i <+> text "::" <+>  ppType t') $$ 
+     text "%code" <+> assignRes <+> text fun <> ppTuple (arg_names)
+ | optHugs = text "primitive" <+> ppName i <+> text "::" <+> ppType t'
+ | otherwise = -- FFI decls.
+     text "foreign import"			<+> 
+     ppCallConv False cconv		        <+>
+        -- this is not quite right in the case of Hugs,
+	-- since we will need to supply the name of the stub DLL.
+     (if (null dllname || has_structs || optNoDllName) then empty else text (show dllname))	<+>
+     let fun_name | has_structs = doubleQuotes (ppName i)
+                  | otherwise   = text (show fun)
+     in
+     fun_name					                    <+>
+      (if optUnsafeCalls || not safe then text "unsafe" else empty) <+> 
+      ppName i <+> text "::"			                    <+>
+     ppType t
+    where
+      {-
+        We keep the illusion that Integers are valid FFI types on the Hugs
+	side right until the very last, when we expand out an Integer into
+	a pair of Int32 arguments and results.
+      -}
+     t' 
+       | optLongLongIsInteger = expandIntegers t
+       | otherwise	      = t
+      
+     -- Use the next line instead if you haven't go the latest
+     -- GC sources (i.e., ones which support qualified names).
+     -- t'	        = unqualTy t
+
+     assignRes =
+       case res of
+         TyApply _{-io-} [(TyCon tc)] ->
+	   case qName tc of
+	     "()" -> empty
+	     _    -> text "res1 ="
+         _ -> empty
+	      
+
+     (args,res) = splitFunTys t
+     arg_names  = zipWith (\ arg _ -> text ("arg" ++ show arg)) [(1::Int)..] args
+
+ppHDecl (PrimCast cconv i ty has_structs args res_ty)
+ | optGreenCard =
+    text "" $$
+    text "%fun" <+> ppName i <+> text "::" <+>  ppType ty' $$ 
+    text "%code" $$
+    vsepPrefix (text "% ")
+     [ ppDeclResult
+     , text "typedef" <+> ppResultType <+> 
+          parens ( text "__" <> ppCallConv True cconv <+> char '*' <+> text "__funptr") <+>
+	  ppTuple ppArgs <> semi
+     , text "__funptr" <+> ppName i <> semi
+     , ppName i <+> equals <+> text "(__funptr)arg1" <> semi
+     , ppAssignResult <+> ppName i <> ppTuple ppCasmArgs <> semi
+     ] $$
+    text ""
+ | optHugs = text "primitive" <+> ppName i <+> text "::" <+> ppType ty'
+ | optTargetGhc =
+   ppName i <+> text "::" <+>  ppType ty $$ 
+   ppName i <+> hsep params <+> equals <+> text "_casm_" <+> 
+   ppLitLit (
+      ppDeclResult $$
+      text "typedef" <+> ppResultType <+> 
+        parens ( text "__" <> ppCallConv True cconv <+> char '*' <+> text "__funptr") <+>
+	ppTuple ppArgs <> semi $$
+      text "__funptr" <+> ppName i <> semi $$
+      ppName i <+> equals <+> text "(__funptr)%0" <> semi $$
+      ppAssignResult <+> ppName i <> ppTuple ppMethArgs <> semi $$
+      ppReturnResult <> semi) <+> hsep params
+ | otherwise =
+   text "foreign import" <+> ppCallConv False cconv   <+> 
+   (if has_structs then text (show i) else text "\"dynamic\"") <+>
+   (if optUnsafeCalls then text "unsafe" else empty) <+> 
+   ppName i <+> text "::" <+> ppType ty
+  where
+    ppLitLit x = text "``" <> x <> text "\'\'"
+
+    ty' 
+     | optLongLongIsInteger = expandIntegers ty
+     | otherwise	    = ty
+
+    -- Use the next line instead if you haven't go the latest
+    -- GC sources (i.e., ones which support qualified names).
+    --ty' = unqualTy ty
+
+    params = map (\ x -> text ('a':show x)) [1..(length args)]
+    ppMethArgs = map (\ x -> text ('%':show x)) (tail [0..(length args - 1)])
+    ppCasmArgs = map (\ x -> text ("arg"++show x)) [2..(length args)]
+
+    ppArgs = map (\ (x, arg_ty) -> text (snd arg_ty) <+> text ('a':show x)) (zip [(1::Int)..] (tail args))
+
+    (ppDeclResult, ppResultType, ppAssignResult, ppReturnResult) = 
+     case res_ty of
+       (_,"void") -> ( empty, text "void", empty, empty )
+       (_,res)    -> ( text res <+> text "res1" <> semi
+		     , text res
+		     , text "res1" <+> equals
+		     , text "%r=res1"
+		     )
+
+
+ppHDecl (Entry cconv ci hi t) = 
+  text "foreign export" <+> ppCallConv False cconv <+> text (show ci) <+> ppName hi <+> text "::" <+>
+  ppType t
+
+ppHDecl (Callback cconv i t) = 
+  text "foreign export" <+> ppCallConv False cconv <+> text "dynamic" <+> ppName i <+> text "::" <+>
+  ppType t
+
+ppHDecl (ExtLabel c_name h_name t)
+ = text "foreign label" <+> text (show c_name) <+> text h_name <+> text "::" <+> ppType t
+
+ppHDecl (TyD td) = ppTyDecl td
+ppHDecl (Class ctxt cname tvrs decls) =
+  hang (text "class"  <+> ppContext True ctxt <+>
+        ppQName cname <+> hsep (map ppTyVar tvrs) <+>
+	if (notNull decls) then text "where" else empty)
+   2   (vsep (map ppHDecl decls))
+ppHDecl (Instance ctxt cname t decls) =
+  hang (text "instance" <+> ppContext True ctxt <+> ppQName cname <+> parens (ppType t) <+>
+	if (notNull decls) then text "where" else empty)
+   2   (vsep (map ppHDecl decls))
+ppHDecl (Include s)
+  | optGreenCard = text "%#include" <+> text s
+  | otherwise    = empty
+  
+ppHDecl (Haskell s) = text s
+ppHDecl (CCode s)   = text "{- BEGIN_C_CODE" $$ text s $$ text "END_C_CODE-}"
+ppHDecl EmptyDecl   = empty
+\end{code}
+
+\begin{code}
+expandIntegers :: Type -> Type
+expandIntegers (TyFun t1@(TyCon t) t2)
+  | qName t == "Integer"  = TyFun tyInt32 (TyFun tyInt32 (expandIntegers t2))
+  | otherwise             = TyFun t1 (expandIntegers t2)
+expandIntegers (TyFun t1 t2) = TyFun (expandIntegers t1) (expandIntegers t2)
+expandIntegers t@(TyApply (TyCon tc) [(TyCon x)])
+  | qName tc == "IO" && qName x == "Integer" = TyApply (TyCon tc) [TyTuple [tyInt32, tyInt32]]
+  | otherwise = t
+expandIntegers t = t
+\end{code}
+
+
+\begin{code}
+ppPat :: Pat -> AbsHDoc a
+ppPat (PatVar v)      = ppVarName v
+ppPat (PatLit v)      = ppLit v
+ppPat PatWildCard     = char '_'
+ppPat (PatTuple pats) = ppTuple (map ppPat pats)
+ppPat (PatAs v p)     = ppVarName v <> char '@' <> parens (ppPat p)
+ppPat (PatCon v [])   = ppVarName v
+ppPat (PatCon v pats) = parens (ppVarName v <+> hsep (map ppPat pats))
+ppPat (PatList pats)  = ppList (map ppPat pats)
+ppPat (PatIrrefut p)  = char '~' <> parens (ppPat p)
+ppPat (PatRecord v fields) =
+ ppVarName v <> braces (hsep (punctuate comma (map ppField fields)))
+ where
+  ppField (var,p) = ppVarName var <+> equals <+> ppPat p
+
+ppCaseAlt :: CaseAlt -> AbsHDoc a
+ppCaseAlt (Alt p [GExpr [] e]) = ppPat p <+> text "->" <+> ppExpr e
+ppCaseAlt (Alt p ls) = 
+    hang (ppPat p)
+     2   (vsep (map (ppGuardedExpr (text "->")) ls))
+ppCaseAlt (Default mb_v e) =
+  pp_v <+> text "->" <+> ppExpr e
+  where
+   pp_v = case mb_v of Nothing -> char '_' ; Just v  -> ppVarName v
+
+\end{code}
+
+\begin{code}
+type ExprDoc = PPDoc (Bool,Bool)
+
+ifTop :: (ExprDoc -> ExprDoc )
+      -> (ExprDoc -> ExprDoc )
+      -> ExprDoc
+      -> ExprDoc
+ifTop onTrueF onFalseF d =
+ getPPEnv 	      $ \ (top,flg) ->
+ setPPEnv (False,flg) $
+ if top then
+    onTrueF d
+ else
+    onFalseF d
+
+ifOnTop :: ExprDoc
+        -> ExprDoc
+        -> ExprDoc
+ifOnTop ifIs ifIsn't =
+ getPPEnv 	      $ \ (top,flg) ->
+ setPPEnv (False,flg) $
+ if top then
+    ifIs
+ else
+    ifIsn't
+
+ifDo :: ExprDoc -> ExprDoc -> ExprDoc
+ifDo onTrue onFalse = 
+ getPPEnv $ \ (_,flg) ->
+ if flg then
+    onTrue
+ else
+    onFalse
+
+setDo :: Bool -> ExprDoc -> ExprDoc
+setDo flg d = getPPEnv $ \ (top,_) -> setPPEnv (top,flg) d
+
+setTop :: Bool -> ExprDoc -> ExprDoc
+setTop flg d = getPPEnv $ \ (_,dof) -> setPPEnv (flg,dof) d
+\end{code}
+
+\begin{code}
+ppExpr :: Expr -> PPDoc a
+ppExpr e = setPPEnv (True, False) (ppExprDo e)
+
+ppExprDo :: Expr -> ExprDoc
+ppExprDo (Lit l)      = ppLit l
+ppExprDo (Var v)      = ppVarName v
+ppExprDo (Con v)      = ppConName v
+ppExprDo (Lam [] e)   = ppExprDo e
+ppExprDo (Lam pats e) = char '\\' <+> hsep (map ppPat pats) <+> text "->" <+> setDo False (ppExprDo e)
+ppExprDo (Apply (Apply e args1) args2) = ppExprDo (Apply e (args1++args2))
+ppExprDo (Apply e [])      = ppExprDo e
+ppExprDo (Apply e@(Lam _ _) args) = parens (ppExprDo e) <+> hsep (map ppArg args)
+ppExprDo (Apply e args)    = 
+  ifOnTop (ppExprDo e <+> vsep (map ppArg args))
+          (ppExprDo e <+> hsep (map ppArg args))
+ppExprDo (RApply e1 (Lam pats e2))  =
+  ppExprDo e1 <+> ppVarName dollarName <+> char '\\' <+> 
+  hsep (map ppPat pats) <+> text "->" $$ ppExprDo e2
+ppExprDo (RApply e1 e2)  =
+  ppExprDo e1 <+> ppVarName dollarName <+> ppExprDo e2
+ppExprDo (Tup args)         = ppTuple (map ppExprDo args)
+ppExprDo (List elts)        = ppListVert (map ppExprDo elts)
+ppExprDo (InfixOp e1 op e2) = ppExprDo e1 <+> ppr_op <+> ppExprDo e2
+   where
+     ppr_op 
+       | not (isOpName op) = ppVarName op
+       | otherwise	   = char '`' <> ppVarName op <> char '`'
+
+ppExprDo (BinOp bop e1 e2) = parens ( ppExprDo e1 <+> ppBinOp bop <+> ppExprDo e2)
+ppExprDo (UnOp uop e)      = parens ( ppUnOp uop <+> ppExprDo e)
+ppExprDo (Bind m p n)      =
+   ifTop (\ d -> hang (text "do") 2 (setDo True d)) (id)
+         (ifDo ((ppPat p <+> text "<-" <+> ppExprDo m) $$ ppExprDo n)
+               (hang (ppExprDo m <+> ppQualName bindName <+> 
+	                  char '\\' <+> ppPat p <+> text "->")
+                 0   (ppExprDo n)))
+ -- this assumes that m has type "M ()", which is the
+ -- case for HaskellDirect. ToDo: Record return type
+ -- for the left arg to a bind, so that we can make sure
+ -- that this is really the case.
+ --
+ppExprDo (Bind_ m (Return (Tup []))) = ppExprDo m
+
+ppExprDo (Bind_ m n)       =
+   ifTop (\ d -> hang (text "do") 2 (setDo True d)) (id)
+         (ifDo ((ppExprDo m) $$ ppExprDo n)
+               (hang (ppExprDo m <+> ppQualName bind_Name)
+                 0   (ppExprDo n)))
+
+ppExprDo (Return e@(Tup _)) = ppQualName prelReturn <+> ppExprDo e
+ppExprDo (Return e)         = ppQualName prelReturn <+> parens (ppExprDo e)
+ppExprDo (If c e1 e2)       = 
+  hang (text "if" <+> ppExprDo c)
+   2   (text "then" <+> ppExprDo e1 $$
+   	text "else" <+> ppExprDo e2)
+ppExprDo (Case e alts)      =
+  hang (text "case" <+> ppExprDo e <+> text "of")
+   3   (vsep (map ppCaseAlt alts))
+ppExprDo (Let [] e) = ppExprDo e
+ppExprDo (Let binders (Let binders2 e)) = ppExprDo (Let (binders++binders2) e)
+ppExprDo (Let binders e)    =
+  ifDo ((text "let" <+> (vsep (map ppBinding binders))) $$ ppExprDo e)
+       ((hang (text "let")
+          1  (vsep (map ppBinding binders))) $$
+        text "in" $$
+        ppExprDo e)
+ppExprDo (WithTy e ty) = parens (ppExprDo e <+> text "::" <+> ppType ty)
+\end{code}
+
+Expressions in argument position - leave out 
+as many parens as possible:
+
+\begin{code}
+ppArg :: Expr -> ExprDoc
+ppArg (Lit l)    = ppLit l
+ppArg (Var v)    = ppVarName v
+ppArg (Con v)    = ppConName v
+ppArg e@(Tup _)  = ppExprDo e
+ppArg e@(List _) = ppExprDo e
+ppArg e          = parens (ppExprDo e)
+\end{code}
+
+
+\begin{code}
+ppBinding :: Binding -> ExprDoc
+ppBinding (Binder v e) = ppName v <+> equals <+> setTop False (ppExprDo e)
+
+ppBinOp :: BinaryOp -> PPDoc a
+ppBinOp op =
+   case op of
+     Xor     -> ppQName xorName
+     Or      -> ppQName orName
+     And     -> ppQName andName
+     Shift d -> ppQOp (case d of { L -> shiftLName ; R -> shiftRName })
+     Add     -> ppQName addName
+     Sub     -> ppQName subName
+     Div     -> ppQOp divName
+     Mod     -> ppQOp modName
+     Mul     -> ppQName mulName
+     LogAnd  -> ppQName logAndName
+     LogOr   -> ppQName logOrName
+     Gt      -> ppQName gtName
+     Ge      -> ppQName geName
+     Eq      -> ppQName eqName
+     Le      -> ppQName leName
+     Lt      -> ppQName ltName
+     Ne      -> ppQName neName
+
+ppUnOp :: UnaryOp -> PPDoc a
+ppUnOp op =
+ case op of
+  Minus  -> ppQName negateName
+  Plus   -> ppQName addName
+  Not    -> ppQName complementName
+  Negate -> ppQName notName
+  Deref  -> empty
+\end{code}
+
+\begin{code}
+ppType :: Type -> AbsHDoc a
+ppType ty = setPPEnv top_prec (ppTypePrec ty)
+
+ppFunType :: Type -> AbsHDoc a
+ppFunType ty = setPPEnv fun_prec (ppTypePrec ty)
+
+ppConType :: Type -> AbsHDoc a
+ppConType ty = setPPEnv tycon_prec (ppTypePrec ty)
+
+type TypeDoc = PPDoc Int
+
+setPrec :: Int -> TypeDoc -> TypeDoc
+setPrec = setPPEnv
+
+gePrec :: Int -> TypeDoc -> TypeDoc -> TypeDoc
+gePrec prec onTrue onFalse = 
+  getPPEnv $ \ val ->
+  if val >= prec then
+     onTrue
+  else
+     onFalse
+     
+ppTypePrec :: Type -> TypeDoc
+ppTypePrec (TyVar _ tv)       = ppTyVar tv
+ppTypePrec (TyCon tc)         = ppTyCon tc
+ppTypePrec (TyApply con [])   = ppTypePrec con
+ppTypePrec (TyApply con args) = 
+   mbParen tycon_prec (setPrec tycon_prec $ hsep (map ppTypePrec (con:args)))
+ppTypePrec (TyList t)         = 
+   brackets (setPrec top_prec (ppTypePrec t))
+ppTypePrec (TyTuple ts)       = 
+   setPrec top_prec (ppTuple (map ppTypePrec ts))
+ppTypePrec (TyCtxt ctxt t)    =
+   ppContext True ctxt <+> ppTypePrec t
+ppTypePrec (TyFun a b)        = 
+   mbParen fun_prec ((setPrec fun_prec (ppTypePrec a)) <+> text "->" <+> setPrec top_prec (ppTypePrec b))
+
+mbParen :: Int -> TypeDoc -> TypeDoc
+mbParen new_prec d = gePrec new_prec (parens d) d
+
+top_prec, fun_prec, tycon_prec :: Int
+top_prec   = (0::Int)
+fun_prec   = (1::Int)
+tycon_prec = (2::Int)
+
+ppVarName :: VarName -> PPDoc a
+ppVarName v = ppQName v
+
+ppConName :: ConName -> PPDoc a
+ppConName cn = ppQName cn
+
+ppTyVar :: TyVar -> PPDoc a
+ppTyVar tv = ppQName tv
+
+ppTyCon :: TyCon -> PPDoc a
+ppTyCon s = ppQName s
+
+ppQName :: QualName -> PPDoc a
+ppQName = ppQualName
+
+ppQOp :: QualName -> PPDoc a
+ppQOp op = char '`' <> ppQualName op <> char '`'
+
+{-
+  = Con_1 ...
+  | Con_2 ...
+  ...
+-}
+ppConDecls :: [ConDecl] -> AbsHDoc a
+ppConDecls [] = error "ppConDecls: shouldn't happen, invalid Haskell."
+ppConDecls (dcon:dcons) =
+  vsep
+    ( (equals <+> ppConDecl dcon) :
+      (map (\ dc -> text "|" <+> ppConDecl dc) dcons))
+
+ppConDecl :: ConDecl -> AbsHDoc a
+ppConDecl (RecDecl nm fields)
+  | null fields = ppName nm 
+  | otherwise   =
+     ppName nm <+> braces (vsep (punctuate comma (map ppField fields)))
+      where
+       ppField (v, t)   = ppName v <+> text "::" <+> ppBangType t
+ppConDecl (ConDecl nm args) =
+      ppName nm <+> hsep (map ppBangType args)
+
+ppBangType :: BangType -> AbsHDoc a
+ppBangType (Banged ty)   = char '!' <> setPPEnv tycon_prec (ppTypePrec ty)
+ppBangType (Unbanged ty) = setPPEnv tycon_prec (ppTypePrec ty)
+
+\end{code}
+
+\begin{code}
+ppContext :: Bool -> Context -> AbsHDoc a
+ppContext _ (CtxtTuple [])   = empty
+ppContext withDArrow (CtxtTuple ts)
+  = ppTuple (map (ppContext False) ts) <+> (if withDArrow then text "=>" else empty)
+ppContext withDArrow (CtxtClass c ts) = ppQName c <+> hsep (map ppConType ts) <+> (if withDArrow then text "=>" else empty)
+
+ppTyDeclKind :: TyDeclKind -> AbsHDoc a
+ppTyDeclKind Newtype = text "newtype"
+ppTyDeclKind Data    = text "data"
+\end{code}
+
+\begin{code}
+vsepPrefix :: PPDoc a -> [PPDoc a] -> PPDoc a
+vsepPrefix pre ls = vsep (map ((<>) pre) ls)
+
+{- UNUSED:
+unqualTy :: Type -> Type
+unqualTy t =
+ case t of
+   TyVar f tv     -> TyVar f (unqualName tv)
+   TyCon tc       -> TyCon (unqualName tc)
+   TyApply f args -> TyApply (unqualTy f) (map unqualTy args)
+   TyList tl      -> TyList (unqualTy tl)
+   TyTuple ts     -> TyTuple (map unqualTy ts)
+   TyCtxt c t1    -> TyCtxt c (unqualTy t1)
+   TyFun a b      -> TyFun (unqualTy a) (unqualTy b)
+ where
+   unqualName qv = qv{qModule=Nothing,qDefModule=Nothing}
+-}
+\end{code}
+
+\begin{code}
+ppGuardedExprs :: [GuardedExpr] -> AbsHDoc a
+ppGuardedExprs []             = empty -- bogus, but we won't flag this fact here.
+ppGuardedExprs [(GExpr [] e)] = equals <+> (ppExpr e)
+ppGuardedExprs ls	      = 
+   vcat (map (\ (GExpr gs e) ->
+		text "|" <+> 
+		hsep (punctuate comma (map ppExpr gs)) <+> 
+		equals <+>
+		(ppExpr e)) ls)
+
+ppGuardedExpr :: AbsHDoc a -> GuardedExpr -> AbsHDoc a
+ppGuardedExpr _    (GExpr [] e) = ppExpr e
+ppGuardedExpr sepr (GExpr gs e) = 
+  text "|" <+> hsep (punctuate comma (map ppExpr gs)) <+> sepr <+> ppExpr e
+
+\end{code}
+
+\begin{code}
+ppTyDecl :: TyDecl -> AbsHDoc a
+ppTyDecl (TypeSyn nm args ty) = text "type" <+> hsep (map text (nm:args)) <+> equals <+> ppType ty
+ppTyDecl (TyDecl Data tycon ty_args [con_decl] derivs) =
+  ppTyDeclKind Data       <+> 
+  ppName tycon            <+>
+  hsep (map text ty_args) <+> 
+  equals		  <+>
+  hang (ppConDecl con_decl)
+   2   (ppDeriving derivs)
+
+ppTyDecl (TyDecl kind tycon ty_args con_decls derivs) =
+  hang (ppTyDeclKind kind <+> ppName tycon <+> hsep (map text ty_args)) 
+   1   (ppConDecls con_decls $$ -- nb: ppConDecls insert the '='
+        ppDeriving derivs)
+\end{code}
+
+\begin{code}
+ppDeriving :: [QualName] -> AbsHDoc a
+ppDeriving [] = text "" -- want a new line
+ppDeriving ds = 
+  text "deriving" <+> ppTuple (map ppQName ds) <> text ""
+\end{code}
+
+\begin{code}
+ppValName :: QualName -> AbsHDoc a
+ppValName i
+ | not optQualInstanceMethods = ppName (qName i)
+ | otherwise		      = ppQName i
+\end{code}
+
+\begin{code}
+isOpName :: QualName -> Bool
+isOpName q = 
+  case qName q of
+    ""    -> False
+    (n:_) -> not (isAlpha n) && n /= '_'
+\end{code}
+ src/PpCore.lhs view
@@ -0,0 +1,642 @@+% 
+% (c) The Foo Project, Universities of Glasgow & Utrecht, 1997-8
+%
+% @(#) $Docid: Feb. 9th 2003  14:51  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Pretty printing the Core IDL type
+
+\begin{code}
+module PpCore where
+
+import CoreIDL
+import Literal
+import BasicTypes
+import PP
+import Opts  ( optDebug, optHaskellToC, optShortHeader,
+	       optCompilingMsIDL
+	     )
+import List  ( partition )
+import Utils ( mapMb, notNull )
+import Attribute ( hasAttributeWithName )
+
+import Maybe ( fromMaybe )
+import Char  ( isAlphaNum, toUpper )
+
+\end{code}
+
+The Doc type when pretty printing core IDL carries around
+a flag indicating how much info we should print out.
+
+\begin{code}
+type CoreDoc = 
+  PPDoc ( Bool   -- output debugging information?
+        , Bool   -- output as C decls?
+	, Bool   -- within a C comment?
+	, Bool   -- expand library decls?
+	, String -- type of the 'this' pointer.
+		 -- "" => not processing an object interface.
+	)
+
+showCore :: CoreDoc -> String
+showCore cd = showPPDoc cd (optDebug, False, False, True, "")
+
+showHeader :: String -> CoreDoc -> String
+showHeader fname cd = 
+  showPPDoc (text "#ifndef" <+> text fname' $$
+  	     text "#define" <+> text fname' $$
+	     cd $$ text "#endif")
+	    (False, True{-as C-}, False, True, "")
+ where
+  uu     = "__"
+  fname' = uu ++ map canon fname ++ uu
+
+  canon x
+   | isAlphaNum x = toUpper x
+   | otherwise    = '_'
+
+
+ppCore :: [Decl] -> CoreDoc
+ppCore ls = vsep (map ppDecl ls) $$ text ""
+
+ppHeaderDecl :: [Id] -> Decl -> CoreDoc
+ppHeaderDecl is d = vsep (map forwardDecl is) $$
+		    ppDecl d $$
+		    text ""
+ where 
+   forwardDecl i
+     | is_object =
+       let nm = idName i in
+       text "#ifndef __" <> text nm <> text "_FWD_DEFINED__" $$
+       text "#define __" <> text nm <> text "_FWD_DEFINED__" $$
+       text "typedef struct" <+> text nm <+> text nm <> semi $$
+       text "#endif"
+     | otherwise = empty
+    where
+     attrs      = idAttributes i
+     is_object  = 
+	attrs `hasAttributeWithName` "object" ||
+	attrs `hasAttributeWithName` "odl"
+    
+
+setDebug :: Bool -> CoreDoc -> CoreDoc
+setDebug deb d = 
+  getPPEnv $ \ (_,as_c,comment,flg,str) ->
+  setPPEnv (deb,as_c,comment,flg,str) d
+
+getCommentFlag :: (Bool -> CoreDoc) -> CoreDoc
+getCommentFlag cont = getPPEnv $ \ (_,_,comment,_,_) -> cont comment
+
+inComment :: CoreDoc -> CoreDoc
+inComment d1 = 
+  getPPEnv $ \ (deb,c,_,flg,str) ->
+  setPPEnv (deb,c,True,flg,str) d1 
+
+setLibFlag :: Bool -> CoreDoc -> CoreDoc
+setLibFlag flg d =
+  getPPEnv $ \ (deb,as_c,comment,_,str) ->
+  setPPEnv (deb,as_c,comment,flg,str) d
+
+ifTopLevLib :: CoreDoc -> CoreDoc -> CoreDoc
+ifTopLevLib if_true if_false = 
+  getPPEnv $ \ (_,_,_,flg,_) ->
+  if flg then
+    if_true
+  else
+    if_false
+
+
+ifC :: CoreDoc -> CoreDoc -> CoreDoc
+ifC onTrue onFalse = 
+  getPPEnv $ \ (_,flg,_,_,_) ->
+  if flg then
+     onTrue
+  else
+     onFalse
+
+setThisType :: String -> CoreDoc -> CoreDoc
+setThisType this_ty d = 
+  getPPEnv $ \ (deb,as_c,comment,flg,_) ->
+  setPPEnv (deb,as_c,comment,flg,this_ty) d
+
+getThisType :: (String -> CoreDoc) -> CoreDoc
+getThisType cont =
+  getPPEnv $ \ (_,_,_,_,this_ty) ->
+  cont this_ty
+
+whenNotC :: CoreDoc -> CoreDoc
+whenNotC d = ifC empty d
+
+commentOutIfC :: CoreDoc -> CoreDoc
+commentOutIfC d = ifC (commentOut d) d
+
+commentOut :: CoreDoc -> CoreDoc
+commentOut d = 
+   getCommentFlag $ \ flg ->
+      start_comment flg <> inComment d <> end_comment flg
+ where
+  start_comment insideComment
+   | insideComment = empty
+   | otherwise     = text "/*"
+
+  end_comment insideComment
+   | insideComment = empty
+   | otherwise     = text "*/"
+
+getIfC :: (Bool -> CoreDoc) -> CoreDoc
+getIfC cont = 
+  getPPEnv $ \ (_,flg,_,_,_) ->
+  cont flg
+
+ifDebug :: CoreDoc -> CoreDoc -> CoreDoc
+ifDebug onTrue onFalse =
+  getPPEnv $ \ (flg,_,_,_,_) ->
+  if flg then
+     onTrue
+  else
+     onFalse
+\end{code}
+
+\begin{code}
+ppDecl :: Decl -> CoreDoc
+ppDecl (Typedef i t orig_ty) =
+  (if ignorable then commentOutIfC else id) $
+  case orig_ty of
+   FunTy cc res ps ->
+        text "typedef" <+> ppType (resultType res) <+> 
+	     parens ( ppCallConv True cc <+> char '*' <> ppId i id) <>
+             ppTuple (map ppParam ps) <> semi
+   _ ->
+    ifC (ppId i (\ x -> text "typedef" <+> x <+> ppType orig_ty))
+        (ppId i (\ x -> text "typedef" <+> x <+> ppType t)) <> semi
+ where
+  ignorable = idAttributes i `hasAttributeWithName` "ignore"
+
+ppDecl (Constant i _ o_t e) =
+ ifC (text "#define") (text "const") <+> ppId i (<> ifC empty (ppType o_t)) <+> ifC empty equals <+> ppExpr e <> ifC empty semi
+
+ppDecl (Interface i is_ref inherit decls)
+  | is_ref =
+    ifC empty
+	(ppId i ($+$ (text "interface")) <> semi)
+  | otherwise  =
+    ifC
+      pprIface
+      ((hang (ppIdVert i ($+$ (text "interface")) <+> pp_inherit <+> char '{')
+	 3   (ppCoreDecls decls (map ppDecl decls))) $$
+       char '}' <> semi)
+ where
+  attrs      = idAttributes i
+  is_object  = 
+	attrs `hasAttributeWithName` "object" ||
+	attrs `hasAttributeWithName` "odl"
+
+  pprIface
+   | optShortHeader || pure_dispatch = commentOutIfC (text "interface" <+> text (idOrigName i) <+> text "{};")
+   | not is_object = text "typedef struct" <+> text (idOrigName i) <+> char '*' <> text (idOrigName i) <> semi
+   | otherwise     =
+--      text "typedef struct" <+> text (idOrigName i) <+> text (idOrigName i) <> semi $$
+      ppCoreDecls non_meth_decls (map ppDecl non_meth_decls) $$
+       (hang (text "typedef struct" <+> text (idOrigName i ++ "Vtbl") <+> char '{')
+         3   ((if optHaskellToC then id else setThisType (idOrigName i))
+	        ( ppInhMethodFiller $$ 
+		  ppCoreDecls meth_decls (map ppDecl the_meth_decls)))) $$
+       char '}' <+> text (idName i ++ "Vtbl") <> semi $$ text "" $$
+       hang (text "struct" <+> text (idName i) <+> char '{')
+         2  (text "struct" <+> text (idName i ++ "Vtbl") <+> char '*' <> text "lpVtbl" <> semi $$
+	     char '}' <> semi) $$
+       if optHaskellToC then 
+          empty 
+       else
+	  text "#ifdef COBJMACROS" $$
+	  vcat (map (mkObjMacros (idName i)) decls) $$
+	  text "#endif" <+> commentOut (text "COBJMACROS")
+
+  the_meth_decls = map (removeAttrs) meth_decls
+
+  removeAttrs m  = m{declId=(declId m){idAttributes=[]}}
+
+  (meth_decls, non_meth_decls) = partition isMethod decls
+
+  ppInhMethodFiller
+    | is_idispatch || is_iunknown = empty
+    | is_dispatch  = ppDecls (map (\ x -> text "void*" <+> text ("reserved"++show x)) [(0::Int)..6])
+    | otherwise    = ppDecls (map (\ x -> text "void*" <+> text ("reserved"++show x)) [(0::Int)..2])
+
+  is_dispatch = any (\ x -> qName (fst x) == "IDispatch") inherit
+
+  (is_idispatch, is_iunknown) =
+    case (idOrigName i) of
+      "IDispatch" -> (True, False)
+      "IUnknown"  -> (False, True)
+      _		  -> (False, False)
+
+  pure_dispatch = not is_idispatch && is_dispatch && not has_dual
+    
+  has_dual = (idAttributes i) `hasAttributeWithName` "dual"
+
+  isMethod (Method _ _ _ _ _) = True
+  isMethod _		      = False
+
+  mkObjMacros if_nm (Method methId _ _ args _) = 
+    hang (text "#define" <+> text (if_nm ++ '_':idOrigName methId) <> arg_list <+> char '\\')
+      5  (text "(This)->lpVtbl->" <> text (idOrigName methId) <> arg_list)
+   where
+    arg_list = parens (hcat (punctuate comma (map text ("This" : map (idName.paramId) args))))
+  mkObjMacros _ _ = empty
+
+  pp_inherit
+   | not optDebug && optCompilingMsIDL =
+      case inherit of
+	  []        -> empty
+	  ((x,_):_) -> char ':' <+> text (qName x)
+   | otherwise =
+   case inherit of
+     [] -> empty
+     ls -> char ':' <+> hsep (punctuate comma (map (\ (x,y) -> ppQualName x <> 
+							       commentOut (text (show y))) ls))
+
+ppDecl (Module i decls) =
+ ifC (ppCoreDecls decls (map ppDecl decls))
+     (hang (ppIdVert i ($+$ (text "module")) <+> char '{')
+        3   (ppCoreDecls decls (map ppDecl decls)) $$
+      text "};")
+
+ppDecl (DispInterface i (Just d) _ _) =
+ ifC (commentOutIfC (text "dispinterface" <+> text (idName i) <+> text "{};"))
+     (hang (ppIdVert i ($+$ (text "dispinterface")) <+> char '{')
+        3  (ppId (declId d) (\ x -> x <+> text "interface") <> semi $$ ifDebug (ppDecl d) empty) $$
+      whenNotC (text "};"))
+
+ppDecl (DispInterface i _ props meths) =
+ ifC (commentOutIfC (text "dispinterface" <+> text (idName i) <+> text "{};"))
+     (hang (ppIdVert i ($+$ (text "dispinterface")) <+> char '{')
+       3   (hang (text "properties:")
+             2   (ppDecls (map ppDecl props)) $$
+	    hang (text "methods:")
+             2   (ppCoreDecls meths (map ppDecl meths))) $$
+      text "};")
+
+ppDecl (Library i [])
+ | not optDebug  = text "importlib" <> parens (text (show (idName i))) <> semi
+ppDecl (Library i decls) =
+ ifC 
+   (commentOutIfC (text "library" <+> text (idOrigName i)))
+   (ppIdVert i ($+$ (text "library"))) $$
+ ifTopLevLib 
+   (commentOutIfC (char '{') $$
+    setLibFlag False (ppFwdDecls $$
+		      ppCoreDecls decls (map ppDecl decls)) $$
+    commentOutIfC (text "};"))
+   (commentOutIfC (text "{};"))
+ where
+  ifaces = filter isInterface decls
+
+  ppFwdDecls = vsep (map ppFwdDecl ifaces)
+
+  ppFwdDecl (Interface ifaceId _ inherit _) =
+   ifC (if pure_dispatch then 
+           empty 
+	else 
+	   text "typedef struct" <+> text (idOrigName ifaceId) <+> text (idOrigName ifaceId) <> semi)
+       (text "interface" <+> text (idOrigName ifaceId) <> semi)
+    where
+     is_idispatch =
+      case (idOrigName ifaceId) of
+        "IDispatch" -> True
+        _	    -> False
+
+     pure_dispatch = not is_idispatch && is_dispatch && not has_dual
+     is_dispatch = any (\ x -> qName (fst x) == "IDispatch") inherit
+     has_dual = (idAttributes ifaceId) `hasAttributeWithName` "dual"
+
+  ppFwdDecl _ = empty
+
+  isInterface Interface{} = True
+  isInterface _		  = False
+
+
+ppDecl (CoClass i decls) =
+ ifC (commentOutIfC (text "coclass" <+> text (idOrigName i) <+> text "{};"))
+     (hang (ppIdVert i ($+$ (text "coclass")) <+> char '{')
+       3   (ppDecls (map ppCoClassDecl decls)) $$
+      commentOutIfC (text "};"))
+
+ppDecl (Property i ty _ _ _) = ppId i ($$ (ppType ty)) <> semi
+
+ppDecl (Method i cconv res args _) = 
+  getThisType $ \ str ->
+  (if (null str) then -- not an object method.
+     ppId i ($$ (ifC (text "extern") empty <+> ppResult res <+> ppCallConv True cconv))
+   else
+     ppResult res <+> parens ( ppMethodId i (\ x -> ppCallConv True cconv <+> char '*' <> x)))
+       <+>
+  pp_param <> semi
+ where
+  ppMethodId mid cont = ifC (ppId i' cont) (ppId mid  cont)
+
+  attrs = idAttributes i
+
+  i'
+   | attrs `hasAttributeWithName` "propget" = i{idOrigName="get"++idOrigName i}
+   | attrs `hasAttributeWithName` "propput" = i{idOrigName="put"++idOrigName i}
+   | attrs `hasAttributeWithName` "propputref" = i{idOrigName="put"++idOrigName i}
+   | otherwise				       = i
+
+  pp_param =
+   getThisType $ \ str ->
+   let
+    ty = Pointer Ref False (Name str str Nothing Nothing Nothing Nothing)
+
+    args' 
+     | null str  = args
+     | otherwise = (Param (Id "This" "This" Nothing []) 
+			  In ty ty False):args
+   in			  
+   ppTupleVert (map ppParam args')
+
+ppDecl (HsLiteral str) = whenNotC (text "haskell" <> parens (text str) <> semi)
+ppDecl (CInclude  str) = text "include" <+> text str
+ppDecl (CLiteral str) = 
+  ifC (text str)
+      (text "cpp_quote" <> parens (text str))
+
+ppCoreDecls :: [Decl] -> [CoreDoc] -> CoreDoc
+ppCoreDecls [] [] = empty
+ppCoreDecls (CInclude _ : as) (b:bs) = b $$ ppCoreDecls as bs
+ppCoreDecls (CLiteral _ : as) (b:bs) = b $$ ppCoreDecls as bs
+ppCoreDecls (_:as) (b:bs)            = b $$ ppCoreDecls as bs
+ppCoreDecls [] as = vcat as
+ppCoreDecls _ []  = empty
+
+ppCoClassDecl :: CoClassDecl -> CoreDoc
+ppCoClassDecl (CoClassInterface i _)     = ppId i (<+> whenNotC (text "interface"))
+ppCoClassDecl (CoClassDispInterface i _) = ppId i (<+> whenNotC (text "dispinterface"))
+\end{code}
+
+@ppId@ takes the extra function argument to allow the attributes
+to be printed not immediately next to the identifier name.
+For instance, when printing out an interface decl, the attributes of the
+interface id should be prefixed to the "interface" keyword rather
+than next to the id.
+
+\begin{code}
+ppId :: Id -> (CoreDoc -> CoreDoc) -> CoreDoc
+ppId i ty
+  | notNull attrs = (ty (commentOutIfC (ppList (map ppAttr attrs)))) <+> ppModule i
+  | otherwise     = ty empty <+> ppModule i
+  where
+    attrs  = idAttributes i
+
+--
+-- [ a1
+-- , a2
+--   ..
+-- ]
+-- foo
+
+ppIdVert :: Id -> (CoreDoc -> CoreDoc) -> CoreDoc
+ppIdVert i ty		  
+  | notNull attrs' = (ty (commentOutIfC (ppListVert (map ppAttr attrs')))) <+> ppModule i
+  | otherwise      = ty empty <+> ppModule i
+  where
+    attrs  = idAttributes i
+    attrs' = filter notIsAny attrs
+    
+    notIsAny (Attribute "any" _) = False
+    notIsAny _			 = True
+
+-- print the name of an Id, and possibly what 
+-- file/module it is coming from.
+ppModule :: Id -> CoreDoc
+ppModule i =
+   ifDebug 
+      (text $
+       case mb_mod of
+         Nothing  -> nm
+         Just m   -> m++'.':nm)
+      (text (idOrigName i))
+   where
+    mb_mod = idModule i
+    nm     = idName i
+
+\end{code}
+
+\begin{code}
+ppAttr :: Attribute -> CoreDoc
+ppAttr (AttrMode dir)        = ppDirection dir
+ppAttr (Attribute nm [])     = text nm
+ppAttr (Attribute nm ps)     = text nm <> ppTuple (map ppAttrParam ps)
+ppAttr (AttrDependent r ps)  = ppDepReason r <> ppTuple (map ppAttrParam ps)
+
+ppAttrParam :: AttributeParam -> CoreDoc
+ppAttrParam (ParamLit  l) = ppLit l
+ppAttrParam (ParamType t) = ppType t
+ppAttrParam (ParamExpr e) = ppExpr e
+ppAttrParam (ParamVar n)  = text n
+ppAttrParam ParamVoid     = empty
+ppAttrParam (ParamPtr a)  = char '*' <> ppAttrParam a
+
+ppDepReason :: DepReason -> CoreDoc
+ppDepReason r = 
+  text $
+  case r of
+    SizeIs   -> "size_is"
+    LengthIs -> "length_is"
+    LastIs   -> "last_is"
+    FirstIs  -> "first_is"
+    MaxIs    -> "max_is"
+    MinIs    -> "min_is"
+    SwitchIs -> "switch_is"
+\end{code}
+
+\begin{code}
+ppType :: Type -> CoreDoc
+ppType (Integer Natural True)   = text "int"
+ppType (Integer LongLong True)  = text "int64" 
+ppType (Integer LongLong False) = text "uint64" 
+ppType (Integer sz signed) = (if signed then empty else text "unsigned") <+> ppSize sz
+ppType StablePtr =
+  ifC (text "unsigned long")
+      (text "stablePtr")
+
+ -- (res (*)(args))
+ppType (FunTy cc res params) = ppFunTy cc res params
+
+ppType (Float sz) =
+ case sz of
+   Short    -> text "float"
+   Long     -> text "double"
+   LongLong -> text "long double"
+   Natural  -> text "float"	       
+
+ppType (Char signed)
+ | signed    = text "signed char"
+ | otherwise = text "char"
+
+ppType WChar  = text "wchar_t"
+ppType Bool   = text "boolean"
+ppType Octet  = text "char"
+ppType Any    = text "any"
+ppType Object = text "Object"
+ppType (String _ isUnique mb_expr) =
+  ifC (text "char*")
+      ((if isUnique then text "[unique]" else empty) <> text "string" <> pp_expr)
+ where
+  pp_expr =
+   fromMaybe empty
+             (mapMb (\ e -> char '<' <> ppExpr e <> char '>') mb_expr)
+
+ppType (WString isUnique mb_expr) =
+ ifC (text "WCHAR*")
+     ((if isUnique then text "[unique]" else empty) <> text "wstring" <> pp_expr)
+ where
+  pp_expr =
+   fromMaybe empty
+             (mapMb (\ e -> char '<' <> ppExpr e <> char '>') mb_expr)
+
+ppType (Sequence t mb_expr _) =
+  text "sequence" <> char '<' <>
+  ppType t <> pp_expr
+  where
+  pp_expr =
+   fromMaybe (char '>')
+             (mapMb (\ e -> comma <> ppExpr e <> char '>') mb_expr)
+
+ppType (Fixed e i) =
+  text "fixed" <> char '<' <>
+  ppExpr e <> comma <> ppILit i <> char '>'
+
+--ppType (Name nm onm mod attrs (Just ty) _) = ppModule (Id nm nm mod (fromMaybe [] attrs)) <> parens (ppType ty)
+
+ppType (Name nm onm md attrs _ _) = ppModule (Id nm onm md (fromMaybe [] attrs))
+ppType (Struct i [] _) = text "struct" <+> ppId i id
+ppType (Struct i fields _) = 
+ hang (ppId i (<> text "struct") <+> char '{')
+   3  (ppDecls (map ppField fields)) $$
+ char '}'
+
+ppType (Enum i _ vals) = 
+ (hang (ppId i (<> text "enum") <+> char '{')
+   3   (vsep (punctuate comma (map ppEnumValue vals)))) $$
+ char '}'
+
+ppType (Union nm switch_ty switch_nm union_nm switches) = 
+ hang (ppId nm (<> text "union") <+> commentOutIfC (text "switch" <>
+       parens (ppId switch_nm (<> (ppType switch_ty))) <+> ppId union_nm id) <+> char '{')
+   3  (ppDecls (map (ppSwitch True) switches)) $$
+ char '}'
+
+ppType (UnionNon tag switches) = 
+ hang (ppId tag (<> text "union") <+> char '{')
+   3  (ppDecls (map (ppSwitch False) switches)) $$
+ char '}'
+
+ppType (CUnion i fields _) = 
+ hang (ppId i (<> text "union") <+> char '{')
+   3  (ppDecls (map ppField fields)) $$
+ char '}'
+
+ppType (Pointer pt _ ty)   = ppType ty <> ppPointerType pt <> char '*'
+ppType (Array t dims)      = ppArray empty  t dims
+ppType Void                = text "void"
+ppType (Iface nm md onm _ _ _) = ppModule (Id nm onm md [])
+
+ppType (SafeArray t)      = text "SAFEARRAY" <> ifC (char '*') (parens (ppType t))
+				    -- In .h mode, we run the risk of nested comments here
+				    -- should we have a SAFEARRAY of a SAFEARRAY (yes, it does
+				    -- happen!).
+
+ppEnumValue :: EnumValue -> CoreDoc
+ppEnumValue (EnumValue vi (Left val)) = ppId vi id <+> equals <+> text (show val)
+ppEnumValue (EnumValue vi (Right e))  = ppId vi id <+> equals <+> ppExpr e
+
+
+ppArray :: CoreDoc -> Type -> [Expr] -> CoreDoc
+ppArray d t dims = ppType t <+> d <> ppArrayDims dims
+
+ppPointerType :: PointerType -> CoreDoc
+ppPointerType pt =
+  ifDebug (char '{' <> p <> char '}') empty
+ where
+  p =
+   char $
+   case pt of
+     Ref    -> 'r'
+     Ptr    -> 'p'
+     Unique -> 'u'
+
+ppFunTy :: CallConv -> Result -> [Param] -> CoreDoc
+ppFunTy cc res params = 
+  parens (ppResult res <+> 
+          parens (ppCallConv True cc <+> char '*') <>
+	  ppTuple (map ppParam params))
+
+ppArrayDims :: [Expr] -> CoreDoc
+ppArrayDims []    = ifC (text "[1]") (text "[]")
+ppArrayDims [e]   = char '[' <> ppExpr e <> char ']'
+ppArrayDims [l,h] = char '[' <> ppExpr l <+> text ".." <+> ppExpr h <> char ']'
+ppArrayDims _     = error "PpCore.ppArrayDims: don't know how to handle an interval with more than elts"
+\end{code}
+
+\begin{code}
+ppExpr :: Expr -> CoreDoc
+ppExpr e =
+ case e of
+  Binary bop e1 e2 -> ppExpr e1 <+> ppBinaryOp bop <+> ppExpr e2
+  Cond e1 e2 e3    -> ppExpr e1 <+> char '?' <+> ppExpr e2 <+> char ':' <+> ppExpr e3
+  Unary op e1      -> parens (ppUnaryOp op <+> ppExpr e1)
+  Var nm           -> text nm
+  Lit l            -> ppLit l
+  Cast t e1        -> parens (ppType t) <> parens (ppExpr e1)
+  Sizeof t         -> text "sizeof" <> parens (ppType t)
+\end{code}
+
+\begin{code}
+ppParam :: Param -> CoreDoc
+ppParam (Param i _ (Array t e) _ _) = ppArray (ppId i id) t e
+ppParam (Param i _ t orig_ty _) = 
+   ppId i (<> (ppType t <> ppOrig))
+ where 
+  ppOrig = ifDebug (parens (ppType orig_ty)) empty
+
+ppSwitch :: Bool -> Switch -> CoreDoc
+ppSwitch inEncUn (SwitchEmpty Nothing) 
+  | inEncUn   = commentOutIfC (text "default: ")
+  | otherwise = commentOutIfC (text "[default] ")
+ppSwitch inEncUn (SwitchEmpty (Just ls)) = commentOutIfC (ppCaseLabels inEncUn (map fst ls))
+ppSwitch inEncUn (Switch i labs t orig_ty) =
+ hang (commentOutIfC $ ppCaseLabels inEncUn labs)
+  3   (ppId i (<> (ppType t <> ppOrig)))
+ where 
+  ppOrig = ifDebug (parens (ppType orig_ty)) empty
+
+ppField :: Field -> CoreDoc
+ppField (Field i (Array t es) _ _ _) = ppArray (ppId i id) t es
+ppField (Field i t orig_ty mb_sz _) = 
+   ppId i (<> (ppType t <> ppOrig)) <> pp_bit_field
+ where 
+  pp_bit_field = 
+    case mb_sz of
+      Nothing -> empty
+      Just x  -> char ':' <+> text (show x)
+
+  ppOrig = ifDebug (parens (ppType orig_ty)) empty
+
+ppResult :: Result -> CoreDoc
+ppResult (Result red_ty orig_ty) =
+  ifDebug (ppType red_ty <> parens (ppType orig_ty))
+	  (ppType orig_ty)
+
+ppCaseLabels :: Bool -> [CaseLabel] -> CoreDoc
+ppCaseLabels inEncUn ls 
+ | inEncUn    = hsep (punctuate (text ": ") (map ppCaseLabel ls))
+ | otherwise  = brackets (hsep (punctuate comma (map ppCaseLabel ls)))
+
+ppCaseLabel :: CaseLabel -> CoreDoc
+ppCaseLabel Default  = text "default"
+ppCaseLabel (Case e) = text "case" <+> ppExpr e
+
+\end{code}
+
+ src/PpIDLSyn.lhs view
@@ -0,0 +1,396 @@+%
+% (c) The Foo Project, University of Glasgow, 1998
+%
+% @(#) $Docid: Feb. 9th 2003  15:07  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+\begin{code}
+module PpIDLSyn where
+
+import IDLSyn
+import PP
+import Literal
+import BasicTypes
+import Utils
+import Maybe
+import Opts ( optDebug, optIncludeAsImport, optExcludeSysIncludes )
+
+type IDLDoc = PPDoc ()
+
+showIDL :: IDLDoc -> String
+showIDL i = showPPDoc i ()
+
+ppIDL :: String -> [Defn] -> IDLDoc
+ppIDL src ds
+ | optIncludeAsImport || optExcludeSysIncludes = vsep (map ppDefn (trundle [Nothing] ds)) $$ text ""
+ | otherwise          = vsep (map ppDefn ds) $$ text ""
+  where
+     -- remove the included bits
+    trundle     _          []     = []
+    trundle ks@(keepIt:ls) (x:xs) = 
+      case x of
+        IncludeStart ix | isJust keepIt || is_src -> trundle (Just forKeeps : ks) xs
+	   where
+	    is_src   = src == ix
+	    forKeeps = fromMaybe True keepIt && is_src
+	IncludeEnd -> trundle ls xs
+	_ | fromMaybe True keepIt -> x : trundle ks xs
+	  | otherwise		  -> trundle ks xs
+    trundle [] ls = ls
+\end{code}
+
+\begin{code}
+ppId :: Id -> IDLDoc
+ppId iden =
+  case iden of
+     Id i             -> text i
+     AttrId as i      -> ppAttrs False as <> ppId i
+     ArrayId i dims   -> ppId i <> ppList (map ppExpr dims)
+     FunId i mb_cc ps -> (pp_callconv mb_cc) <+> ppId i <> parens (ppParams ps)
+     BitFieldId x i   -> ppId i <+> char ':' <> text (show x)
+     CConvId cc i     -> (pp_callconv (Just cc)) <+> ppId i
+     Pointed quals i  -> text (replicate len '*') <> ppId i 
+       where
+        len = length quals
+  where
+   pp_callconv mb_cc = mapFromMb empty (ppCallConv True) mb_cc
+    
+\end{code}
+
+%*
+%
+\subsection{Pretty printing a definition}
+%
+%*
+
+\begin{code}
+ppDefn :: Defn -> IDLDoc
+
+ppDefn (Typedef t attrs ids) 
+  = text "typedef"        <+> 
+     ppAttrs False attrs  <+> 
+     ppType t             <+>
+     hsep (punctuate comma (map ppId ids)) <> semi
+
+ppDefn (TypeDecl t)      = ppType t <> semi
+ppDefn (ExternDecl t is) = text "extern" <+> ppType t <+> hsep (punctuate comma (map ppId is)) <> semi
+
+ppDefn (Constant i attrs t expr) 
+  = ppAttrs False attrs <> text "const" <+> ppType t <+> ppId i <+> equals <+> ppExpr expr <> semi
+
+ppDefn (Attributed attrs d)
+  = ppAttrs False attrs $+$ ppDefn d 
+
+ppDefn (Attribute ids read_only t)
+  | read_only = text "readonly" <+> ppType t <+> hsep (punctuate comma (map ppId ids)) <> semi
+  | otherwise = ppType t <+> hsep (punctuate comma (map ppId ids)) <> semi
+
+ppDefn (Operation i res_ty mb_raises mb_ctxt)
+  = ppType res_ty <+> {-pp_callconv <+> -} ppId i
+    {- ((ppId i <> lparen) $$
+      ppParams params) <> rparen -} <+> ppRaises mb_raises <+> ppContext mb_ctxt <> semi
+--    where
+--     pp_callconv = mapFromMb empty (ppCallConv True) mb_callconv
+
+ppDefn (Exception i mems)
+  = text "exception" <+> ppId i <+> ppMembers mems <> semi
+
+ppDefn (Interface i inherit ds)
+  = hang (text "interface" <+> ppId i <+> 
+          hsep (punctuate (text ":") 
+	                  (text "" : map text inherit)) <+> char '{')
+      4 (ppDefns ds) $$
+    char '}' <> semi
+
+ppDefn (Forward i)
+  = text "interface" <+> ppId i <> semi
+
+ppDefn (Module i ds)
+  = text "module" <+> ppId i <+> char '{' $$
+     ppDefns ds $$
+    char '}' <> semi
+
+ppDefn (DispInterface i props meths)
+  = text "dispinterface" <+> ppId i <+> char '{' $$
+     hang (text "properties:")
+      8   (ppProps props)  $$
+     hang (text "methods:")
+      8   (ppDefns meths)  $$
+    char '}' <> semi
+
+ppDefn (DispInterfaceDecl i iid)
+  = text "dispinterface" <+> ppId i <+> char '{' $$
+     text "interface" <+> ppId iid <> semi $$
+    char '}' <> semi
+
+ppDefn (CoClass i c_mems) -- [(Bool, Id, [Attribute])]
+  = text "coclass" <+> ppId i <+> 
+    char '{' $$
+      ppCoCMembers c_mems $$
+    char '}' <> semi
+
+ppDefn (Library i ds)
+  = text "library" <+> ppId i <+> char '{' $$
+      ppDefns ds $$ 
+    char '}' <> semi
+
+ppDefn (CppQuote str)
+  = text "cpp_quote" <+> parens (doubleQuotes (text str))
+
+ppDefn (HsQuote str)
+  = text "hs_quote" <+> parens (doubleQuotes (text str))
+
+ppDefn (CInclude str)
+  = text "include" <+> text str
+
+ppDefn (Import imps) 
+ | optDebug = 
+   text "import" <+> 
+   hsep (punctuate comma (map (\ (v,defs) -> doubleQuotes (text v) $$ vcat (map ppDefn defs)) imps)) <> semi
+ | otherwise =
+   text "import" <+> 
+   hsep (punctuate comma (map (\ (v,_) -> doubleQuotes (text v)) imps)) <> semi
+
+ppDefn (ImportLib imp)
+  = text "importlib" <+> parens (doubleQuotes (text imp)) <> semi
+
+ppDefn (Pragma str)
+  = text "#pragma" <+> text str 
+
+ppDefn (IncludeStart _) = empty
+ppDefn IncludeEnd = empty
+
+\end{code}
+
+%*
+%
+\subsection{Pretty printing types}
+%
+%*
+
+\begin{code}
+ppType :: Type -> IDLDoc
+
+ppType (TyApply f a)  = ppType f <+> ppType a
+
+ppType (TyInteger sz) = ppSize sz
+
+ppType (TyFloat sz) =
+ text $
+ case sz of
+   Short    -> "float"
+   Long     -> "double"
+   LongLong -> "long double"
+   Natural  -> "float"
+
+ppType (TySigned isSigned)
+   | isSigned  = text "signed"
+   | otherwise = text "unsigned"
+
+ppType TyChar = text "char"
+ppType TyWChar  = text "wchar"
+ppType TyBool   = text "boolean" -- or was that bool?
+ppType TyOctet  = text "octet"   -- aka byte
+ppType TyAny    = text "any"
+ppType TyObject = text "Object"
+ppType TyStable = text "StablePtr"
+ppType TyVoid    = text "void"
+ppType TyBString = text "BSTR"
+ppType (TyPointer t)  = ppType t <> char '*'
+ppType (TyArray t es) = ppType t <> ppList (map ppExpr es)
+ppType (TySafeArray t)   = text "SAFEARRAY" <> parens (ppType t)
+ppType (TyFun mb_cc t ps) = 
+   ppType t <+> parens (pp_callconv <+> char '*') <>
+   parens (ppParams ps)
+ where
+   pp_callconv = mapFromMb empty (ppCallConv True) mb_cc
+
+ppType (TyStruct mb_tag [] _)  = 
+  text "struct" <+> tag
+  where
+   tag = mapFromMb empty ppId mb_tag
+
+ppType (TyStruct mb_tag mems mb_pack) = 
+  hang (text "struct" <+> tag <+> char '{')
+    4  (ppMembers mems) $$
+  char '}' $$
+  fromMaybe empty (fmap (\ x -> text "/*" <> text (show x) <> text "*/") mb_pack)
+  where
+   tag = mapFromMb empty ppId mb_tag
+
+ppType (TyString mblen) = 
+  text "string" <>
+  (mapFromMb empty 
+             (\ l -> char '<' <> ppExpr l <> char '>') mblen)
+
+ppType (TyWString mblen) = 
+  text "wstring" <>
+  (mapFromMb empty 
+             (\ l -> char '<' <> ppExpr l <> char '>') mblen)
+
+ppType (TySequence t mblen) =
+  text "sequence" <> 
+  char '<' <> ppType t <>
+  (mapFromMb empty  (\ l -> comma <> ppExpr l) mblen) <>
+  char '>' 
+
+ppType (TyFixed Nothing)      = text "fixed"
+ppType (TyFixed (Just (e,i))) =
+  text "fixed" <> char '<' <>
+    ppExpr e <> comma <+> ppILit i <> 
+  char '>'
+
+ppType (TyName nm _) = text nm
+ppType (TyIface nm) = text nm
+
+ppType (TyUnion struct_name ty switch_name union_name switches) =
+  text "union"     <+>
+  (mapFromMb empty ppId struct_name) <+>
+  text "switch"    <>
+  parens (ppType ty <+> ppId switch_name) <+>
+  (mapFromMb empty ppId union_name) <+> char '{' $+$
+  ppSwitches switches $+$
+  char '}'
+
+ppType (TyCUnion mbid members _) =
+  hang (text "union" <+> 
+        (mapFromMb empty ppId mbid) <+> char '{')
+    3 (ppMembers members) $+$
+  char '}'
+
+ppType (TyUnionNon mbid switches) =
+  hang (text "union" <+> 
+        (mapFromMb empty ppId mbid) <+> char '{')
+    3 (ppSwitches switches) $+$
+  char '}'
+
+ppType (TyEnum mbid enums) =
+  hang (text "enum" <+> pp_id <+> char '{')
+   3   (pp_vals) $$
+  char '}'
+  where
+   pp_id = mapFromMb empty ppId mbid
+   pp_vals =
+     vsep (punctuate comma (map ppVal enums))
+
+   ppVal (i, attrs, Nothing) = ppAttrs False attrs <> ppId i
+   ppVal (i, attrs, Just e)  = ppAttrs False attrs <> ppId i <+> equals <+> ppExpr e
+
+ppType (TyQualifier q)     = ppQualifier q
+
+\end{code}
+
+%*
+%
+\subsection{Misc pretty printing functions}
+%
+%*
+
+\begin{code}
+ppMembers :: [Member] -> IDLDoc
+ppMembers mems = ppDecls (map ppMember mems)
+
+ppMember :: Member -> IDLDoc
+ppMember (t, attrs, ids) =
+  ppAttrs False attrs <+> ppType t <+> hcat (punctuate comma (map ppId ids))
+
+ppDefns :: [Defn] -> IDLDoc
+ppDefns ls = ppDecls (map ppDefn ls)
+
+ppAttrs :: Bool -> [Attribute] -> IDLDoc
+ppAttrs isParam [] 
+  | isParam   = text "[in]"
+  | otherwise = empty
+ppAttrs _ as = ppList (map ppAttr as)
+
+ppAttr :: Attribute -> IDLDoc
+ppAttr (Mode dir)      = ppDirection dir
+ppAttr (Attrib f [])   = ppId f
+ppAttr (Attrib f args) = 
+  ppId f <> parens (hsep (punctuate comma (map ppAttrParam args)))
+  where
+   ppAttrParam EmptyAttr    = empty
+   ppAttrParam (AttrExpr e) = ppExpr e
+   ppAttrParam (AttrLit l)  = ppLit l
+   ppAttrParam (AttrPtr a)  = char '*' <> ppAttrParam a
+
+ppCoCMembers :: [CoClassMember] -> IDLDoc
+ppCoCMembers mems = ppDecls (map ppCoCMember mems)
+
+ppCoCMember :: CoClassMember -> IDLDoc
+ppCoCMember (isInterface, i, attrs) =
+  ppAttrs False attrs <+> 
+  (if isInterface then
+      text "interface"
+   else
+      text "dispinterface") <+>
+  ppId i
+
+ppParams :: [Param] -> IDLDoc
+ppParams ps = vsep (punctuate comma (map ppParam ps))
+
+ppParam :: Param -> IDLDoc
+ppParam (Param nm ty attrs) = ppAttrs True attrs <+> ppType ty <+> ppId nm
+
+ppRaises :: Maybe Raises -> IDLDoc
+ppRaises Nothing    = empty
+ppRaises (Just ids) = 
+  text "raises" <+> 
+  ppTuple (map text ids)
+
+ppContext :: Maybe Context -> IDLDoc
+ppContext Nothing    = empty
+ppContext (Just ids) = 
+  text "context" <+> 
+  ppTuple (map (doubleQuotes.text) ids)
+
+ppProps :: [([Attribute], Type, Id)] -> IDLDoc
+ppProps ls = ppDecls (map ppProp ls)
+
+ppProp :: ([Attribute], Type, Id) -> IDLDoc
+ppProp (as, ty, nm) = ppAttrs False as <+> ppType ty <+> ppId nm
+
+ppSwitches :: [Switch] -> IDLDoc
+ppSwitches ls = ppDecls (map ppSwitch ls)
+
+ppSwitch :: Switch -> IDLDoc
+ppSwitch (Switch labels Nothing) =
+  ppCaseLabels labels
+ppSwitch (Switch labels (Just param)) =
+  ppCaseLabels labels <+> ppParam param
+
+\end{code}
+
+
+%*
+%
+\subsection{Pretty printing expressions}
+%
+%*
+
+\begin{code}
+ppExpr :: Expr -> IDLDoc
+
+ppExpr (Binary op e1 e2) = 
+  parens (ppExpr e1)  <+>
+     ppBinaryOp op    <+>
+  parens (ppExpr e2) 
+
+ppExpr (Unary op e) =
+  ppUnaryOp op <+> parens (ppExpr e)
+
+ppExpr (Var i)    = text i
+ppExpr (Lit l)    = ppLit l
+ppExpr (Cast t e) = parens (ppType t) <> parens (ppExpr e)
+ppExpr (Sizeof ty) = text "sizeof" <> parens (ppType ty)
+ppExpr (Cond a b c) = parens (ppExpr a) <+> char '?' <+> ppExpr b <+> char ':' <+> ppExpr c
+
+ppCaseLabels :: [CaseLabel] -> IDLDoc
+ppCaseLabels ls = hsep (punctuate (text ": ") (map ppCaseLabel ls))
+
+ppCaseLabel :: CaseLabel -> IDLDoc
+ppCaseLabel Default  = text "default"
+ppCaseLabel (Case es) = text "case" <+> ppTuple (map ppExpr es)
+
+\end{code}
+ src/PreProc.lhs view
@@ -0,0 +1,91 @@+% 
+% (c) The Foo Project, University of Glasgow 1998
+%
+% @(#) $Docid: Jun. 7th 2001  17:02  Sigbjorn Finne $
+% @(#) $Contactid: sof@galconn.com $
+%
+
+Running cpp over a file:
+
+\begin{code}
+module PreProc 
+        (
+          preProcessFile
+	, removeTmp
+        ) where
+
+import Data.IORef
+import System.IO.Unsafe
+import CPUTime
+import System  ( getEnv, system )
+import Opts    ( optDebug, optCpp, optinclude_cppdirs, optcpp_defines )
+import List    ( intersperse )
+import Utils   ( prefixDir )
+import IO
+import System.IO
+import Monad
+
+count :: IORef Int
+count = unsafePerformIO (newIORef 0)
+
+prefix :: IORef Integer
+prefix = unsafePerformIO (newIORef 0)
+
+preProcessFile :: String      -- file to run cpp over.
+	       -> IO String   -- where the result is stored.
+preProcessFile fname 
+ | not (optCpp)  = return fname
+ | otherwise     = do
+  pt  <- getCPUTime
+  writeIORef prefix pt
+  v   <- readIORef count
+  writeIORef count (v+1)
+  tmp <- catch (getEnv "TMPDIR") 
+               (\ _ -> return "/tmp/")
+  let tmpnam = prefixDir tmp ("ihc" ++ show pt ++ show v)
+  let
+      tmpnam1 = tmpnam ++ ".c"
+      tmpnam2 = tmpnam ++ ".i"
+      -- In case the CPP we're about to run is insistent
+      -- on the input file ending in .c, we create a
+      -- little temporary file here.
+      oput    = "#include "++show fname ++ "\n"
+      incls   = 
+         " -I. " ++
+	 case optinclude_cppdirs of
+	    [] -> []
+	    ls -> '-':'I':'"': concat (intersperse ":" ls) ++ "\""
+
+      defines = 
+        " -D__midl"         ++ 
+	" -D__restrict="    ++    -- pesky GNU extensions.
+	" -D__restrict__="  ++
+	" -D__extension__=" ++
+	" -D__const__=const" ++
+	" -D__const=const" ++
+        ' ':unwords optcpp_defines
+
+  cpp <- catch (getEnv "CPP")
+               (\ _ -> return ("gcc -E -x c"))
+  hdl <- openFile tmpnam1 WriteMode
+  hPutStrLn hdl oput
+  hClose hdl
+  let cmd = (cpp ++ incls ++ defines ++ ' ':tmpnam1 ++ " -o " ++ tmpnam2)
+  when optDebug (hPutStrLn stderr ("Pre-processing file: "++fname ++ '\n':cmd))
+  res <- system cmd
+  return tmpnam2
+
+removeTmp :: IO ()
+removeTmp = do
+  pt <- readIORef prefix
+  tmp <- catch (getEnv "TMPDIR")
+               ( \ _ -> return "/tmp/")
+  let tmpnam = prefixDir tmp ("ihc" ++ show pt ++ "*")
+  del_cmd <- catch (getEnv "DELPROG")
+                   ( \ _ -> return "rm -f")
+  let cmd    = del_cmd ++ ' ':tmpnam
+  when optDebug (hPutStrLn stderr ("Clearing out temporary files: " ++ cmd))
+  system cmd
+  return ()
+
+\end{code}
+ src/Rename.lhs view
@@ -0,0 +1,980 @@+% 
+% (c) The Foo Project, University of Glasgow 1998-99
+%
+% @(#) $Docid: Dec. 27th 2001  00:14  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+Prior to converting (core) IDL declarations to Haskell, we
+run a renaming pass over the IDL, performing the following
+tasks:
+
+ - fields labels, method names and types are renamed so
+   as to be unique within the scope of a Haskell module.
+ - For imported types, adjust the module name to point to
+   the Haskell interface/module we're importing from.
+
+To be more precise, IDL has three namespaces:
+
+  * struct/union/enum tags
+  * component names (fields, parameter names)
+  * other (typedef names, method names and enumeration constants)
+
+which are mapped onto the following Haskell namespaces:
+
+  * tags            => type constructors (unique per module.)
+  * field labels    => varids (unique per module.)
+  * parameter names => varids (unique per function.)
+  * typedef nms.    => type ids (unique per module.)
+  * method names    => varids (unique per module.)
+  * module names    => modids (unique per translation unit.)
+  * interface names => varids / modids (unique per translation unit.)
+
+An added wrinkle when mapping from IDL into Haskell namespaces is that
+we have to make sure we don't map IDL names onto Haskell keywords/reserved ids.
+
+\begin{code}
+module Rename ( renameDecls, IsoEnv, IfaceNukeEnv ) where
+
+import RnMonad
+import CoreIDL
+import BasicTypes
+import CoreUtils ( mkHaskellTyConName, isMethod, mkIfaceTypeName, getTypeAttributes,
+		   localiseTypes )
+import Attribute ( isConstantAttribute, hasAttributeWithName, hasAttributeWithNames,
+		   sourceAttribute, filterAttributes, filterOutAttributes,
+		   findAttribute, findStringAttributes
+		 )
+import Utils     ( dropSuffix, mapMbM, splitLast )
+import DsMonad   ( TypeEnv, SourceEnv, TagEnv, IfaceEnv )
+import Opts      ( optOneModulePerInterface, optCoalesceIsomorphicMethods,
+		   optPrefixIfaceName, optAppendIfaceName, optInlineTypes,
+		   optCharPtrIsString, optUseStdDispatch
+		 )
+
+import Maybe	 ( isJust, fromMaybe )
+import List      ( isPrefixOf )
+import Monad     ( when, mplus )
+import Char	 ( isUpper, toUpper )
+import Literal
+
+\end{code}
+
+This module's shopfront is @renameDecls@, renaming a list of declarations.
+Along with the renamed decls, @renameDecls@ returns an environment of
+method names. The environment contains signatures of methods for which
+there exist isomorphic definitions, .e.g.,
+
+@
+  interface IA { void foo(); };
+  interface IB { void foo(); };
+@
+
+The @foo@ method in @IB@ is isomorphic to the one in @IA@, a fact that may
+be exploited when generating code, creating just an overloaded version
+of @foo@ (or one that is just not as strongly typed.)
+
+\begin{code}
+renameDecls :: TypeEnv
+	    -> TagEnv
+	    -> SourceEnv
+	    -> IfaceEnv
+	    -> [Decl]
+	    -> ([Decl], IsoEnv, IfaceNukeEnv)
+renameDecls tenv tgenv senv ienv ds =
+   runRnM tenv tgenv senv ienv $ mapM renameDecl (localiseTypes ds)
+
+\end{code}
+
+Renaming individual definitions:
+
+\begin{code}
+renameDecl :: Decl -> RnM Decl
+renameDecl (Typedef i t orig_ty) = do
+  i'   <- renameTypeId (normaliseIdName i)
+  t'   <- renameType t
+  getModuleName $ \ x -> do
+  n_ty <- normaliseTy x [] t'
+  return (Typedef i' n_ty orig_ty)
+renameDecl (Constant i t o_t e) = do
+  i'   <- renameVarId (normaliseIdName i)
+  t'   <- renameType t
+  o_t' <- relabelType False o_t
+  return (Constant i' t' o_t' e)
+renameDecl (Interface i is_ref inh ds) = do
+  i'        <- renameConId (normaliseIdName i)
+  i''       <- renameTypeId i'
+  is_source <- isSourceIface (idName i)
+  let
+   i'''
+    | is_source = i''{idAttributes=sourceAttribute:idAttributes i''}
+    | otherwise = i''
+
+   nm = mkHaskellTyConName (idName i''')
+
+   startOffset
+    | nm == "IUnknown" = Just 0
+    | otherwise	       = Just (sum (map snd inh))
+
+   rnDecl d
+    | isMethod d = do
+        d' <- renameDecl d
+	incMethOffset
+	return d'
+    | otherwise  = renameDecl d
+
+   deps = map remove $
+          filterAttributes (idAttributes i) ["depender"]
+     where
+      remove (Attribute _ [ParamLit (LitLit s)]) = mkHaskellTyConName (snd (splitLast "." s))
+      remove _					 = ""
+
+  ds' <- 
+    setMethOffset startOffset $
+    setIfaceName nm (
+    if optOneModulePerInterface 
+     then withDependers deps (setModuleName nm (withNewVarIdEnv (mapM rnDecl ds)))
+     else mapM rnDecl ds)
+
+  sane_inh <-
+    if optOneModulePerInterface then
+       normaliseInh nm deps inh
+     else
+       getModuleName $ \ mod_nm -> do
+       normaliseInh mod_nm [] inh
+  i_final <-
+     if optOneModulePerInterface then
+        return (i'''{idModule=Nothing})
+      else 
+        normaliseModName i'''
+
+  let d = Interface i_final is_ref sane_inh ds'
+  when (not is_ref) (addIface (idName i_final) d)
+  return d
+
+renameDecl (Module i ms) = do
+  i'  <- renameModId (normaliseIdName i)
+  ms' <- setModuleName (idName i') (inNewModule (mapM renameDecl ms))
+  return (Module i' ms')
+renameDecl (Library i ls) = do
+  i'  <- renameModId (normaliseIdName i)
+  ls' <- setModuleName (idName i') (inNewModule (mapM renameDecl ls))
+  return (Library i' ls')
+renameDecl (DispInterface i ii ps ms) = do
+  i'   <- renameTypeId (normaliseIdName i) >>= \ x -> renameConId x >>= normaliseModName
+  is_source <- isSourceIface (idName i)
+  let
+   i''
+    | is_source = i'{idAttributes=sourceAttribute:idAttributes i'}
+    | otherwise = i'
+
+   nm = mkHaskellTyConName (idName i'')
+   
+   is_wrapper = isJust ii && not optUseStdDispatch
+   
+   reDecl 
+     | is_wrapper = relabelDecl
+     | otherwise  = renameDecl
+
+  (ps',ms') <- 
+     setIfaceName nm (
+     withNew nm ( do
+		   ps' <- mapM reDecl ps
+	           ms' <- mapM reDecl ms
+		   return (ps', ms')))
+
+  ii' <- 
+    case ii of
+      Nothing -> return Nothing
+      Just d  -> do
+         d' <- relabelDecl d
+	 return (Just d')
+  let d = DispInterface i'' ii' ps' ms'
+  addIface (idName i'') d
+  return d
+
+ where
+  withNew nm
+    | optOneModulePerInterface = (setModuleName nm).withNewVarIdEnv
+    | otherwise                = id
+
+renameDecl (CoClass i ls) = do
+  i' <- 
+    if optOneModulePerInterface then
+       renameConId (normaliseIdName i)  >>= renameClassId
+     else
+       renameClassId (normaliseIdName i)
+  ls' <- mapM renameCoCDecl ls
+  case ls' of
+    [x] -> do
+       when optOneModulePerInterface (addNukeIface (idName (coClassId x)) i')
+       return (CoClass i' ls')
+    _   -> return (CoClass i' ls')
+
+renameDecl (Method i cc res ps offs) =
+  getIfaceName $ \ if_name -> do
+  let 
+    -- We pin on the prefixes of propgetters and putters
+    -- here, and rename that.
+    attrs = idAttributes i
+    
+    i'    = normaliseIdName i
+
+    real_i 
+       | attrs `hasAttributeWithName` "propget" 
+       = i'{idName=if_mangle ("get"++mkHaskellTyConName (idName i))}
+
+       | attrs `hasAttributeWithNames` ["propput", "propputref"]
+       = i'{idName=if_mangle ("set"++mkHaskellTyConName (idName i))}
+
+       | optPrefixIfaceName 
+       = i'{idName=if_mangle (idName i)}
+
+       | otherwise = i'
+
+    h_if_name = mkIfaceTypeName if_name
+
+    if_mangle
+     | optPrefixIfaceName = \ x -> h_if_name ++ "_" ++ x
+     | optAppendIfaceName = \ x -> x ++ shorten_if h_if_name
+     | otherwise	  = id
+
+    mangled_i 
+     | optAppendIfaceName && not optOneModulePerInterface
+			  = real_i{idName=if_mangle (idName i')}
+     | otherwise	  = real_i
+
+
+    -- IFooBar => FB
+    -- FooBar  => FB
+    -- IntFoo  => IF
+    shorten_if ls = 
+      case ls of
+        'I':x:xs | isUpper x -> shorten (x:xs)
+	xs     -> shorten xs
+
+    shorten [] = []
+    shorten (x:xs) = toUpper x : filter (isUpper) xs
+
+  the_i <- renameVarId2 mangled_i real_i
+    -- fish out the attributes from the result type, so
+    -- that all of them are attached to the method Id.
+    -- (this is done chiefly to cope with the [ignore]
+    --  attribute, which causes type names to be shorted
+    --  during type renaming and relabelling.)
+    -- 
+    -- see relabelDecl.Method comment as to why [ignore]s
+    -- are filtered out here.
+  let ty_attrs = filterOutAttributes (getTypeAttributes (resultOrigType res))
+  				     ["ignore"]
+  res'  <- renameResult res
+  ps'   <- withNewVarIdEnv $ do
+	    ps' <- mapM renameParam ps
+	    mapM renameParamAttr ps'
+  off   <- getMethOffset
+  when optCoalesceIsomorphicMethods (checkIsomorphicMeth real_i off res' ps')
+  return (Method the_i{idAttributes=idAttributes the_i ++ ty_attrs} cc res' ps' offs)
+
+renameDecl (Property i ty mb_off set_i get_i) = do
+  set_i' <- renameId (normaliseIdName set_i)
+  get_i' <- renameId (normaliseIdName get_i)
+  ty'    <- renameType ty
+  return (Property i ty' mb_off set_i' get_i')
+
+renameDecl d@(HsLiteral _) = return d
+renameDecl d@(CInclude  _) = return d
+renameDecl d@(CLiteral  _) = return d
+\end{code}
+
+\begin{code}
+renameCoCDecl :: CoClassDecl -> RnM CoClassDecl
+renameCoCDecl d = do
+   i'   <- relabelTyConId i >>= normaliseModName
+   mb_d <- lookupIface (idName i')
+   return (d{coClassId=i',coClassDecl=mb_d `mplus` coClassDecl d})
+ where
+  i  = normaliseIdName (coClassId d)
+  
+\end{code}
+
+\begin{code}
+relabelDecl :: Decl -> RnM Decl
+relabelDecl (Interface i is_ref inh ds) = do
+  i'        <- relabelTyConId (normaliseIdName i)
+  ds'       <- mapM relabelDecl ds
+  i''       <- normaliseModName i'
+  getModuleName $ \ mod_nm -> do
+  inh'      <- normaliseInh mod_nm [] inh
+  return (Interface i'' is_ref inh' ds')
+
+relabelDecl (DispInterface i ii ps ms) = do
+  i'  <- relabelTyConId i
+  i'' <- normaliseModName i'
+  ms' <- mapM relabelDecl ms
+  return (DispInterface i'' ii ps ms')
+
+relabelDecl (Method i cc res ps offs) = do
+  i'   <- relabelVarId i
+  ps'  <- mapM relabelParam ps
+    -- [ignore] attributes attached to the result type are *not* 
+    -- propagated to the method Id.
+  let ty_attrs = filterOutAttributes (getTypeAttributes (resultOrigType res))
+  				     ["ignore"]
+  res' <- relabelResult res
+  return (Method i'{idAttributes=idAttributes i' ++ ty_attrs} cc res' ps' offs)
+
+relabelDecl (Property i ty mb_off set_i get_i) = do
+  set_i' <- relabelVarId (normaliseIdName set_i)
+  get_i' <- relabelVarId (normaliseIdName get_i)
+  ty'    <- relabelType False ty
+  return (Property i ty' mb_off set_i' get_i')
+
+relabelDecl d = return d
+
+\end{code}
+
+
+\begin{code}
+renameVarId :: Id -> RnM Id
+renameVarId i = 
+  lookupVarIdAndAddEnv (idName i) $ \ nm ->
+  return (i{idName=nm})
+
+renameModId :: Id -> RnM Id
+renameModId i = 
+  lookupModIdAndAddEnv (idName i) $ \ nm ->
+  return (i{idName=nm})
+
+normaliseModName :: Id -> RnM Id
+normaliseModName i = 
+   getModuleName $ \ mod_nm -> 
+   case (idModule i) of
+     Just x | x == mod_nm -> return (i{idModule=Nothing})
+            | otherwise   -> return (i{idModule=Just (mkHaskellTyConName (dropSuffix x))})
+     _ -> return (i{idModule=Nothing})
+
+normaliseIdName :: Id -> Id
+normaliseIdName i = 
+  case findAttribute "hs_name" (idAttributes i) of
+    Just (Attribute _ [ParamLit (StringLit s)]) -> i{idName=s}
+    _ -> adjustHsNameId i
+
+renameId :: Id -> RnM Id
+renameId i = 
+  lookupVarIdAndAddEnv (idName i) $ \ nm ->
+  return (i{idName=nm})
+
+renameVarId2 :: Id -> Id -> RnM Id
+renameVarId2 i2 i = do
+  flg <- varIdInScope (idName i)
+   -- if it's already there, try using i2 instead.
+  if flg then
+     renameVarId i2
+   else
+     renameVarId i
+
+renameConId :: Id -> RnM Id
+renameConId i = 
+  lookupTyConAndAddEnv (idName i) $ \ nm ->
+  return (i{idName=nm})
+
+renameClassId :: Id -> RnM Id
+renameClassId i = 
+  lookupClassIdAndAddEnv (idName i) $ \ nm ->
+  return (i{idName=nm})
+
+renameTyConId :: Id -> RnM Id
+renameTyConId i = 
+  lookupTyConAndAddEnv (idName i) $ \ nm ->
+  return (i{idName=nm})
+
+renameTypeId :: Id -> RnM Id
+renameTypeId i = 
+  lookupTypeIdAndAddEnv (idName i) $ \ nm ->
+  return (i{idName=nm})
+\end{code}
+
+Check to see if a method's result and parameters are
+isomorphic (upto parameter names) of any others:
+
+\begin{code}
+checkIsomorphicMeth :: Id -> Maybe Int -> Result -> [Param] -> RnM ()
+checkIsomorphicMeth i mem_off res params = do
+  r <- lookupMethod (idOrigName i)  -- use original names here.
+  case r of
+    Nothing -> -- none yet, add an entry for the method and return.
+       addMethod (idOrigName i) (mem_off,res,params)
+
+    Just alts 
+      | any checkOne alts ->  -- name & params matched, store it.
+	    addIsoMethod (idOrigName i) (res, params)
+      | otherwise ->
+            addMethod (idOrigName i) (mem_off, res,params)
+
+ where
+  checkOne (off,r,ps) =
+    off == mem_off &&
+    resultType r == resultType res && 
+    all (\ (p1,p2) -> paramMode p1 == paramMode p2 &&
+		      paramType p1 == paramType p2)  -- ToDo: check attributes too.
+	(zip ps params)
+
+\end{code}
+
+\begin{code}
+renameType :: Type -> RnM Type
+renameType ty = 
+ case ty of
+   Struct i [] mbsz     -> do
+       r  <- lookupTag (idName i)
+       case r of
+         Just (mod,nm) -> do
+	    mb_r <- lookupTypeId nm
+	    let r' = fmap (snd) mb_r
+	    return (Name nm nm mod Nothing r' Nothing)
+	 Nothing -> do
+               --i' <- renameTagId i
+               return (Struct i [] mbsz)
+   Struct i fields mbsz -> do
+     i'        <- renameTyConId i
+      {-
+       Need to rename all the fields ids first, since
+       field types may have attributes that refer to
+       another field (and these might be forward refs).
+       Sigh.
+      -}
+     fields'   <- mapM renameFieldId fields
+     fields''  <- mapM renameField fields'
+     fields''' <- mapM relabelFieldAttr fields''
+     return (Struct i' fields''' mbsz)
+   Enum i flg vals -> do
+     i_r   <- renameTyConId i
+     i'    <- normaliseModName i_r
+     i''   <- 
+	 {- Make sure we've got the right module. -} 
+       case idModule i' of
+         Nothing -> do
+	    r <- lookupTag (idName i)
+	    case r of
+	      Just (Just mod, _) -> setModuleName mod (normaliseModName i')
+		    -- drop the module qualifier if it's the same as the name of the
+		    -- containing module [this prunage is only done in the one-mod-per-iface
+		    -- setting at the moment.]
+	      _     -> return i'
+	 Just _ -> return i'
+
+     vals' <- mapM renameEnumTag vals
+     return (Enum i'' flg vals')
+   Union i t struct_tg un_tg switches -> do
+     i'         <- renameTyConId i
+     struct_tg' <- renameTyConId struct_tg
+     un_tg'     <- renameTyConId un_tg
+     switches'  <- mapM renameSwitch switches
+     return (Union i' t struct_tg' un_tg' switches')
+   UnionNon i switches -> do
+     i'         <- renameTyConId i
+     switches'  <- mapM renameSwitch switches
+     return (UnionNon i' switches')
+   CUnion i fields mbsz -> do
+     i'         <- renameTyConId i
+     fields'    <- mapM renameFieldId fields
+     fields''   <- mapM renameField fields'
+     return (CUnion i' fields'' mbsz)
+   FunTy cc res ps -> do
+     res'	<- renameResult res
+     ps'        <- mapM renameParam ps
+     return (FunTy cc res' ps')
+
+   Pointer _ _ x@(Char _) 
+     | optCharPtrIsString -> return (String x False Nothing)
+
+   Pointer pt isExp t -> do
+     t'		<- renameType t
+     return (Pointer pt isExp t')
+   Array t es   -> do
+     t'		<- renameType t
+     return (Array t' es)
+   SafeArray t  -> do
+     t'		<- renameType t
+     return (SafeArray t')
+
+   Sequence t mb_sz mb_term -> do
+     t' <- renameType t
+     return (Sequence t' mb_sz mb_term)
+
+    {-
+     We adjust the module part of a name (if any) from the name of the IDL source file
+     to the Haskell module that contains it.
+    -}
+   Name nm orig_nm mod mb_attrs mb_ty mb_ti ->
+      getModuleName      $ \ mod_nm ->
+      getDependers       $ \ deps   ->
+      lookupTypeIdEnv (adjustHsName (fromMaybe [] mb_attrs) nm) $ \ nm'    -> do
+      mb_attrs' <- mapMbM renameAttrs mb_attrs
+      ren_ty <- 
+         case mb_ty of
+           Nothing   -> do
+	      r <- lookupTypeId (adjustHsName (fromMaybe [] mb_attrs) nm)
+	      case r of
+	        Nothing -> return (Name nm' orig_nm mod mb_attrs' (fmap snd r) mb_ti)
+		  -- avoid 'obvious' loops.
+		Just (_, t) -> do
+		   t' <- relabelType True t
+		   return (Name nm' orig_nm mod mb_attrs' (Just t') mb_ti)
+
+	   Just ty1   -> do
+             ty' <- relabelType True ty1
+	       -- optionally shortening out imported synonyms
+	       -- can sometimes reduce external dependencies.
+	     
+	     if (optInlineTypes && isJust mod && nm /= "HRESULT") ||
+	        ((getTypeAttributes ty1 ++ fromMaybe [] mb_attrs) `hasAttributeWithName`
+			"ignore") then
+	        return ty'
+              else
+	        return (Name nm' orig_nm mod mb_attrs' (Just ty') mb_ti)
+      normaliseTy mod_nm deps ren_ty
+
+   Iface{} ->
+     getModuleName $ \ if_name ->
+     getDependers  $ \ deps   -> do
+     normaliseTy if_name deps ty
+   _ -> return ty
+
+
+-- drop the module qualifier if it's the same as the name of the
+-- containing module.
+normaliseTy :: String -> [String] -> Type -> RnM Type
+normaliseTy mod_nm ls t = 
+  case t of
+    Iface nm (Just mod) onm attrs is_idis inh
+       | mkHaskellTyConName mod == mod_nm -> do
+               inh1 <- getBestInheritInfo nm inh
+               inh' <- normaliseInh mod_nm ls inh1
+               return (Iface (mkHaskellTyConName nm) Nothing
+	       		     onm attrs is_idis inh')
+    Iface nm mod onm attrs is_idis inh -> do
+               inh1 <- getBestInheritInfo nm inh
+               inh' <- normaliseInh mod_nm ls inh1
+               return (Iface (mkHaskellTyConName nm) mod'
+	       		     onm attrs is_idis inh')
+      where
+	mod' = 
+	 case mod of
+	   Nothing -> mod
+	   Just x  -> 
+	     let h_mod = mkHaskellTyConName x in
+	     if (optOneModulePerInterface && h_mod `elem` ls) then
+		Just (h_mod ++ "Ty")
+	     else
+	        Just h_mod
+
+    Name nm orig_nm mb_mod mb_attrs mb_ty mb_ti -> do
+       mb_ty' <- mapMbM (normaliseTy mod_nm ls) mb_ty
+       let
+	mb_mod' =
+	 case mb_mod of
+	   Just x  | mkHaskellTyConName x == mod_nm -> Nothing
+	           | otherwise			    -> Just (mkHaskellTyConName (dropSuffix x))
+           _ -> Nothing
+
+       return (Name (mkHaskellTyConName nm) orig_nm mb_mod'
+ 		    mb_attrs mb_ty' mb_ti)
+    Pointer x isExp ty   -> do
+        ty' <- normaliseTy mod_nm ls ty
+        return (Pointer x isExp ty')
+    SafeArray ty   -> do
+        ty' <- normaliseTy mod_nm ls ty
+	return (SafeArray ty')
+    Sequence ty mb_sz mb_term -> do
+        ty' <- normaliseTy mod_nm ls ty
+	return (Sequence ty' mb_sz mb_term)
+    Array ty e     -> do
+        ty' <- normaliseTy mod_nm ls ty
+	return (Array ty e)
+    _ -> return t
+
+normaliseInh :: String -> [String] -> InterfaceInherit -> RnM InterfaceInherit
+normaliseInh mod_nm ls inh = do
+   inh' <- updateMethodCount inh
+   mapM tweakMod inh'
+  where
+   tweakMod (q,n) = do
+     m    <- adjustName optOneModulePerInterface q (qModule q)
+     mbNm <- adjustName False q (Just (qName q))
+     let nm = fromMaybe (qName q) mbNm
+     case m of
+       Just x | x == mod_nm -> return (q{qModule=Nothing,qName=nm}, n)
+       _                    -> return (q{qModule=m,qName=nm}, n)
+
+   adjustName isModule q nm =
+    case nm of
+      Nothing
+	| isModule && (qName q) `elem` ls
+	  -> return (Just ((qName q) ++ "Ty"))
+	| otherwise -> return nm
+      Just h_mod ->
+        lookupTyConEnv h_mod $ \ _ -> 
+		-- 11/00:
+                -- suspicious lack of use of the result, but i'm leaving it
+                -- as is, for fear of perturbing anything right now.
+	if (isModule && h_mod `elem` ls) then
+	   return (Just (h_mod ++ "Ty"))
+	 else
+	   return (Just (mkHaskellTyConName h_mod))
+
+{-
+  In the following setting:
+
+	 interface IB;
+         interface IA : IB { ... };
+	 interface IB { ... };
+
+  we need to know how many methods there are in IB when generating
+  the stubs for the IA methods. 'updateMethodCount' updates this info
+  for IA's inherited interfaces, using the type environment that was
+  gathered during desugaring.
+
+  [ -fsort-defns will in most cases sort this one out for us, but 
+    this fwd. ref. situation may still occur in a strongly connected
+    group of ifaces.
+  ]
+
+-}
+updateMethodCount :: InterfaceInherit -> RnM InterfaceInherit
+updateMethodCount is = mapM updateMethod is
+ where
+  updateMethod (i,n)
+    | n /= 0    = return (i,n) -- non-zero method count means
+    			       -- that it is up-to-date.
+    | otherwise = do
+        res <- lookupIface (qName i) 
+	case res of
+	  Just DispInterface{} -> return (i, 7)
+	  Just iface@Interface{declInherit=inhs,declDecls=ds} -> do
+	        -- make sure the parent info is up-to-date.
+	      is' <- updateMethodCount inhs
+	      let inh_meths = sum (map snd is')
+	      	  no_meths  = length (filter isMethod ds)
+		-- update info in env for the benefit of others.
+	      addIface (qName i) (iface{declInherit=is'})
+	        -- ToDo: attribute Interface decls with vtbl sizes.
+	      return (i, no_meths + inh_meths)
+	  _  -> return (i,n)
+{-
+   In case we were processing something like:
+    
+      interface A;
+      interface B { ... f(...A* x...); }
+      interface A : X { ... };
+		       
+   The inheritance info 'X' for A isn't known when processing
+   interface B. Rectify that here.
+-}
+getBestInheritInfo :: Name -> InterfaceInherit -> RnM InterfaceInherit
+getBestInheritInfo nm inh = do
+   res  <- lookupTypeId nm
+   case res of
+     Just (_, Iface _ _ _ _ _ inh2) | not (null inh2) -> return inh2
+     _		          -> return inh
+
+\end{code}
+
+\begin{code}
+relabelType :: Bool -> Type -> RnM Type
+relabelType derefTy ty = 
+ case ty of
+   Struct i [] mbsz     -> do
+       r  <- lookupTag (idName i)
+       case r of
+         Just (mod,nm) -> do
+	    r1 <- lookupTypeId nm
+	    case r1 of
+	     Just (_,t)  -> return (Name nm nm mod Nothing (Just t) Nothing)
+	     Nothing -> do
+	       return (Name nm nm mod Nothing Nothing Nothing)
+	 Nothing -> do
+            --i' <- relabelTyConId i
+            return (Struct i [] mbsz)
+
+   Struct i fields mbsz -> do
+     i'       <- relabelTyConId i
+     fields'  <- mapM relabelField fields
+     fields'' <- mapM relabelFieldAttr fields'
+     return (Struct i' fields' mbsz)
+   Enum i flg vals -> do
+     i'    <- relabelTyConId i >>= normaliseModName
+     vals' <- mapM relabelEnumTag vals
+     return (Enum i' flg vals')
+   Union i t struct_tg un_tg switches -> do
+     i'         <- relabelTyConId i
+     struct_tg' <- relabelTyConId struct_tg
+     un_tg'     <- relabelTyConId un_tg
+     switches'  <- mapM relabelSwitch switches
+     return (Union i' t struct_tg' un_tg' switches')
+   UnionNon i switches -> do
+     i'         <- relabelTyConId i
+     switches'  <- mapM relabelSwitch switches
+     return (UnionNon i' switches')
+   CUnion i fields mbsz -> do
+     i'         <- relabelTyConId i
+     fields'    <- mapM relabelField fields
+     return (CUnion i' fields' mbsz)
+   Pointer _ _ x@(Char _) 
+     | optCharPtrIsString -> return (String x False Nothing)
+   Pointer pt isExp t -> do
+     t'		<- relabelType derefTy t
+     return (Pointer pt isExp t')
+   Array t es   -> do
+     t'		<- relabelType derefTy t
+     return (Array t' es)
+   SafeArray t  -> do
+     t'		<- relabelType derefTy t
+     return (SafeArray t')
+   Sequence t mb_sz mb_term -> do
+     t'		<- relabelType derefTy t
+     return (Sequence t' mb_sz mb_term)
+   FunTy cc res ps -> do
+     res'	<- relabelResult res
+     ps'        <- mapM relabelParam ps
+     return (FunTy cc res' ps')
+   
+    {-
+     We adjust the module part of a name (if any) from the name of the IDL source file
+     to the Haskell module that contains it.
+    -}
+   Name nm orig_nm mod mb_attrs mb_ty mb_ti ->
+     getModuleName $ \ mod_nm ->
+     getDependers  $ \ deps   -> do 
+     lookupTypeIdEnv (adjustHsName (fromMaybe [] mb_attrs) nm) $ \ nm'    -> do
+     mb_attrs' <- mapMbM renameAttrs mb_attrs
+     ren_ty <-
+       case mb_ty of
+          Nothing   -> do
+	    r <- lookupTypeId (adjustHsName (fromMaybe [] mb_attrs) nm)
+	    case r of
+		-- avoid chains of type names..
+		-- iff there's no TypeInfo attached to the outermost, since
+		-- it takes precedence later on as it completely describes the ty.
+	      Just (_, t) | derefTy -> do
+		   t' <- relabelType False t
+		   return (Name nm' orig_nm mod mb_attrs' (Just t') mb_ti)
+	      Just (_,(Name _ _ _ a o_t mb_ti2)) 
+	          | isJust mb_ti      -> return (Name nm' orig_nm mod a o_t mb_ti2)
+	      _			      -> return (Name nm' orig_nm mod mb_attrs' (fmap snd r) mb_ti)
+
+	  Just ty1
+	       | optInlineTypes && isJust mod && nm /= "HRESULT" -> return ty1
+	       | (fromMaybe [] mb_attrs ++ getTypeAttributes ty1) 
+	               `hasAttributeWithName` "ignore"  -> return ty1
+	       | otherwise -> do
+		   ty' <- if False && derefTy then
+		   	     relabelType False ty1
+			   else
+			     return ty1     
+		   return (Name nm' orig_nm mod mb_attrs' (Just ty') mb_ti)
+     normaliseTy mod_nm deps ren_ty
+
+   Iface{} ->
+     getModuleName $ \ if_name ->
+     getDependers  $ \ deps   -> do 
+     normaliseTy if_name deps ty
+
+   _ -> return ty
+
+\end{code}
+
+\begin{code}
+renameParam :: Param -> RnM Param
+renameParam (Param i m ty orig_ty has_dep) = do
+  i'	    <- renameVarId i
+  ty'	    <- renameType ty
+  orig_ty'  <- relabelType True orig_ty
+  return (Param i' m ty' orig_ty' has_dep)
+  
+relabelParam :: Param -> RnM Param
+relabelParam (Param i m ty orig_ty has_dep) = do
+  i'	    <- relabelVarId i
+  ty'	    <- relabelType False ty
+  orig_ty'  <- relabelType False orig_ty
+  return (Param i' m ty' orig_ty' has_dep)
+  
+relabelField :: Field -> RnM Field
+relabelField (Field i ty orig_ty mb_sz mb_off) = do
+  i'	    <- relabelVarId i
+  ty'	    <- relabelType False ty
+  orig_ty'  <- relabelType False orig_ty
+  return (Field i' ty' orig_ty' mb_sz mb_off)
+
+relabelResult :: Result -> RnM Result
+relabelResult (Result ty orig_ty) = do
+  ty'	    <- relabelType False ty
+  orig_ty'  <- relabelType False orig_ty
+  return (Result ty' orig_ty')
+
+relabelSwitch :: Switch -> RnM Switch
+relabelSwitch (Switch i labs ty orig_ty) = do
+  i'	    <- relabelVarId i
+  ty'	    <- relabelType False ty
+  orig_ty'  <- relabelType False orig_ty
+  return (Switch i' labs ty' orig_ty')
+relabelSwitch s = return s
+
+renameFieldId :: Field -> RnM Field
+renameFieldId f = do
+  i'	    <- renameVarId (fieldId f)
+  return (f{fieldId=i'})
+
+renameField :: Field -> RnM Field
+renameField f@Field{fieldType=ty,fieldOrigType=o_ty} = do
+  ty'    <- renameType ty
+  o_ty'  <- relabelType True o_ty
+  return f{fieldType=ty',fieldOrigType=o_ty'}
+
+{- UNUSED
+renameFieldAttr :: Field -> RnM Field
+renameFieldAttr f@Field{fieldId=i} = do
+ attrs    <- mapM renameAttribute (idAttributes i)
+ return (f{fieldId=i{idAttributes=attrs}})
+-}
+
+relabelFieldAttr :: Field -> RnM Field
+relabelFieldAttr f@Field{fieldId=i} = do
+ attrs    <- mapM relabelAttribute (idAttributes i)
+ return (f{fieldId=i{idAttributes=attrs}})
+
+renameResult :: Result -> RnM Result
+renameResult (Result ty orig_ty) = do
+  ty'	    <- renameType ty
+  orig_ty'  <- relabelType True orig_ty
+  return (Result ty' orig_ty')
+
+renameParamAttr :: Param -> RnM Param
+renameParamAttr p = do
+ attrs <- mapM renameAttribute (idAttributes (paramId p))
+ return (p{paramId=(paramId p){idAttributes=attrs}})
+
+renameAttrs :: [Attribute] -> RnM [Attribute]
+renameAttrs = mapM renameAttribute
+
+renameAttribute :: Attribute -> RnM Attribute
+renameAttribute at 
+ | isConstantAttribute at = return at  -- NB: not just an optimisation, 
+				       -- atParams will fail when given a (moded) constant attributes!
+ | otherwise		  = do
+    params <- mapM renameAttrParam (atParams at)
+    return (at{atParams=params})
+
+renameAttrParam :: AttributeParam -> RnM AttributeParam
+renameAttrParam p = 
+ case p of
+  ParamVar nm -> lookupVarIdEnv nm $ \ v -> return (ParamVar v)
+  ParamType t -> do
+     t' <- renameType t
+     return (ParamType t')
+  ParamLit _ -> return p
+  ParamVoid  -> return p
+  ParamPtr ptr -> do
+     p' <- renameAttrParam ptr
+     return (ParamPtr p')
+  ParamExpr e -> do
+     e' <- renameExpr e
+     return (ParamExpr e')
+
+relabelAttribute :: Attribute -> RnM Attribute
+relabelAttribute at 
+ | isConstantAttribute at = return at  -- NB: not just an optimisation, 
+				       -- atParams will fail when given a (moded) constant attributes!
+ | otherwise		  = do
+    params <- mapM relabelAttrParam (atParams at)
+    return (at{atParams=params})
+
+relabelAttrParam :: AttributeParam -> RnM AttributeParam
+relabelAttrParam p = 
+ case p of
+  ParamVar nm -> lookupVarIdEnv nm $ \ v -> return (ParamVar v)
+  ParamType t -> do
+     t' <- relabelType True t
+     return (ParamType t')
+  ParamLit _ -> return p
+  ParamVoid  -> return p
+  ParamPtr ptr -> do
+     p' <- relabelAttrParam ptr
+     return (ParamPtr p')
+  ParamExpr e -> do
+     e' <- renameExpr e
+     return (ParamExpr e')
+
+renameSwitch :: Switch -> RnM Switch
+renameSwitch (Switch i labs ty orig_ty) = do
+  i'	    <- renameVarId i
+  ty'	    <- renameType ty
+  orig_ty'  <- relabelType True orig_ty
+  return (Switch i' labs ty' orig_ty')
+renameSwitch s = return s
+
+renameEnumTag :: EnumValue -> RnM EnumValue
+renameEnumTag (EnumValue nm (Left v)) = do
+ nm' <- renameTyConId (adjustHsNameId nm)
+ return (EnumValue nm' (Left v))
+renameEnumTag (EnumValue nm (Right e)) = do
+ nm' <- renameTyConId (adjustHsNameId nm)
+ e' <- renameExpr e
+ return (EnumValue nm' (Right e'))
+
+relabelEnumTag :: EnumValue -> RnM EnumValue
+relabelEnumTag ev = 
+ let i = enumName ev in
+ lookupTyConEnv (idName i) $ \ nm -> return (ev{enumName=i{idName=nm}})
+
+relabelVarId :: Id -> RnM Id
+relabelVarId i = lookupVarIdEnv (idName i) $ \ v -> return (i{idName=v})
+
+relabelTyConId :: Id -> RnM Id
+relabelTyConId i =
+  lookupTyConEnv (idName i) $ \ v -> return (i{idName=v})
+
+\end{code}
+
+\begin{code}
+renameExpr :: Expr -> RnM Expr
+renameExpr e = 
+ case e of
+   Binary bop e1 e2 -> do
+     e1' <- renameExpr e1
+     e2' <- renameExpr e2
+     return (Binary bop e1' e2')
+   Cond e1 e2 e3 -> do
+     e1' <- renameExpr e1
+     e2' <- renameExpr e2
+     e3' <- renameExpr e3
+     return (Cond e1' e2' e3')
+   Unary op e1 -> do
+     e1'  <- renameExpr e1
+     return (Unary op e1')
+   Var nm -> lookupVarIdEnv nm $ \ v -> return (Var v)
+   Lit _  -> return e
+   Cast t e1 -> do
+    e' <- renameExpr e1
+    return (Cast t e')
+   Sizeof t -> do
+      t' <- relabelType True t
+      return (Sizeof t')
+     
+\end{code}
+
+\begin{code}
+adjustHsNameId :: Id -> Id
+adjustHsNameId i = i{idName=adjustHsName (idAttributes i) (idName i)}
+
+adjustHsName :: [Attribute] -> Name -> Name
+adjustHsName attr nm = rmPrefix prefixes
+ where
+  prefixes = findStringAttributes "hs_prefix" attr
+  
+  rmPrefix [] = nm
+  rmPrefix (x:xs) | x `isPrefixOf` nm = drop (length x) nm
+                  | otherwise         = rmPrefix xs
+
+
+\end{code}
+ src/RnMonad.lhs view
@@ -0,0 +1,462 @@+% 
+% (c) sof 1999-
+%
+% @(#) $Docid: Sep. 18th 2001  09:28  Sigbjorn Finne $
+% @(#) $Contactid: sof@galconn.com $
+%
+
+The 'Renamer' monad - carrying around the environments needed to
+turn a set of IDL decls into a set of uniquely named Haskell decls.
+
+\begin{code}
+module RnMonad 
+	(
+	  RnM
+	, runRnM           -- :: TypeEnv -> TagEnv -> SourceEnv 
+		           -- -> RnM a -> (a, IsoEnv, IfaceNukeEnv)
+	, lookupTypeId     -- :: Name -> RnM (Maybe (Maybe String, Type))
+	, lookupIface      -- :: Name -> RnM (Maybe Decl)
+	, lookupTag        -- :: Name -> RnM (Maybe (Maybe String, String))
+
+	, getMethOffset    -- :: RnM (Maybe Int)
+	, setMethOffset    -- :: Maybe Int -> RnM a -> RnM a
+	, incMethOffset    -- :: RnM ()
+
+	, withNewVarIdEnv  -- :: RnM a -> RnM a
+	, inNewModule      -- :: RnM a -> RnM a
+
+	, isSourceIface           -- :: Name  -> RnM Bool
+
+        , lookupVarIdAndAddEnv    -- :: String -> (String -> RnM a) -> RnM a
+        , lookupTypeIdAndAddEnv   -- :: String -> (String -> RnM a) -> RnM a
+        , lookupTyConAndAddEnv    -- :: String -> (String -> RnM a) -> RnM a
+        , lookupModIdAndAddEnv    -- :: String -> (String -> RnM a) -> RnM a
+        , lookupClassIdAndAddEnv  -- :: String -> (String -> RnM a) -> RnM a
+
+        , lookupTyConEnv    -- :: String -> (String -> RnM a) -> RnM a
+        , lookupTypeIdEnv   -- :: String -> (String -> RnM a) -> RnM a
+        , lookupVarIdEnv    -- :: String -> (String -> RnM a) -> RnM a
+	, varIdInScope      -- :: String -> RnM Bool
+
+        , addIface          -- :: String -> Decl -> RnM ()
+        , addNukeIface      -- :: String -> Id -> RnM ()
+        , addMethod         -- :: String -> (Maybe Int, Result, [Param]) -> RnM ()
+        , addIsoMethod      -- :: String -> (Result,[Param]) -> RnM ()
+        , lookupMethod      -- :: String -> RnM (Maybe [(Maybe Int, Result, [Param])])
+
+        , setIfaceName      -- :: String -> RnM a -> RnM a
+        , setModuleName     -- :: String -> RnM a -> RnM a
+        , withDependers     -- :: [String] -> RnM a -> RnM a
+        , getIfaceName      -- :: (String -> RnM a) -> RnM a
+        , getModuleName     -- :: (String -> RnM a) -> RnM a
+        , getDependers      -- :: ([String] -> RnM a) -> RnM a
+
+	, IsoEnv
+	, IfaceNukeEnv
+	) where
+
+import qualified Env
+import DsMonad   ( TypeEnv, SourceEnv, TagEnv, IfaceEnv )
+import CoreIDL
+import CoreUtils
+import BasicTypes
+import Maybe ( isJust )
+import Utils
+\end{code}
+
+\begin{code}
+newtype RnM a  = RnM (RnEnv -> RnState -> (a, RnState))
+
+type RnEnv = ( String    -- current interface name
+             , String    -- current Haskell module name
+	     , [String]  -- list of interface/modules depending on
+	    		 -- iface/module being currently processed.
+			 -- (Need to record this when fighting Haskell modules
+			 -- in one-module-per-interface mode.)
+	     )
+
+  -- name environments are used to map from the name that occurred
+  -- in the IDL input to the unique name&module to use when generating Haskell.
+  -- 
+  -- while renaming, when a name is encountered, we first check to see whether
+  -- it has got a mapping in the NameEnv. If so, reuse it.
+type NameEnv       = Env.Env String String
+
+  -- UniqueNameEnvs are used to record how many defns of a name N there has been
+  -- /in the current scope/. 
+type UniqueNameEnv = Env.Env String Int
+
+  -- the renaming pass will optionally also spot isomorphic methods, that is,
+  -- methods with the same name, same method table offset (if any -- IDispatch
+  -- methods doesn't have any), result and parameter types.
+  -- 
+  -- The underlying idea is that in many cases interfaces mapped to the same Haskell
+  -- module have identical methods. Spotting the ones that are shared allows us to later
+  -- generate just the one stub, rather than N. 
+type MethodEnv = Env.Env String [(Maybe Int,Result,[Param])]
+type IsoEnv    = Env.Env String [(Result,[Param])]
+
+  -- the 'nuke' interface environment is used for two purposes:
+  --   * some interfaces we may simply want to ignore. Period.
+  --   * sometimes you see IDL input of the form 
+  --            "interface _A {....}; coclass A { interface A; }"
+  --     If you've got the one-module-per-iface/class option turned on,
+  --     you really don't want to generate two modules for this (assuming
+  --     the _A isn't used by anyone else, of course.) We support this by
+  --     slurping the interface into the class' Haskell module, and dropping
+  --     the generation of the interface's module alltogether.
+type IfaceNukeEnv = Env.Env String (Maybe Id)
+			    -- True => don't bother generating code for this iface.
+			    -- False (or not in env) => do generate.
+\end{code}
+
+Carry around a set of environments that keep the various namespaces clean.
+The n-spaces are:
+
+ + typedef'ed names      (turns into type names in Haskell)
+ + constructed tag names (turns into data cons in Haskell)
+ + field labels	    
+	IDL mimics C's rules for overloading field labels, they
+	only have to be unique within a constructed type declaration, not
+	across all definitions in scope. 
+	    
+	Since we're mapping field labels to Haskell record field
+	labels, we have to ensure that a label is unique within the scope
+	of one module (best we can do.)
+
+         => Field labels, method names and constants are all in the same
+            Haskell namespace, so we rename all of these wrt. to one environment.
+
+ + A method's parameter labels is also renamed, although we can assume that
+   they by this stage have been checked to have unique (IDL) names. Why? Because
+   of the potential clash with Haskell keywords, e.g.,
+
+       void foo([in]int _data, [in]int __data);
+
+   should turn into 
+
+       void foo([in]int data0, [in]int data1);
+
+
+   To this, we use a per-method name mapping environment for these.
+
+\begin{code}
+
+type NameSpaceEnv = 
+  ( NameEnv        -- current set of forward/unbound IDL names.
+  , NameEnv        -- mapping from IDL names to (unique) Haskell name
+  , UniqueNameEnv  -- mapping from Haskell names to next unique tag.
+  )
+
+-- big,fat&ugly state:
+data RnState
+ = RnState 
+     { type_env		:: TypeEnv
+     , tg_env		:: TagEnv
+     , src_env		:: SourceEnv
+     , tycon_env        :: NameSpaceEnv
+     , modid_env        :: NameSpaceEnv
+     , varid_env        :: NameSpaceEnv
+     , clsid_env        :: NameSpaceEnv  -- a class' scope is essentially global in Haskell
+     , tyid_env         :: NameSpaceEnv
+     , meth_env		:: MethodEnv
+     , iso_meths	:: IsoEnv
+     , meth_offset	:: Maybe Int
+     , iface_env	:: IfaceEnv
+     , iface_nuke_env   :: IfaceNukeEnv
+     }
+
+runRnM :: TypeEnv
+       -> TagEnv
+       -> SourceEnv
+       -> IfaceEnv
+       -> RnM a -> (a, IsoEnv, IfaceNukeEnv)
+runRnM tenv tgenv senv ienv (RnM act) = 
+  case (act ("","",[]) envs) of 
+    (v, RnState{iso_meths=i,iface_nuke_env=e}) -> (v, i, e)
+ where
+  n_env = (newINameEnv, newINameEnv, newNameEnv)
+  envs = RnState
+            { type_env   = tenv
+	    , tg_env     = tgenv
+	    , src_env    = senv
+	    , tycon_env  = n_env
+	    , modid_env  = n_env
+	    , varid_env  = n_env
+	    , clsid_env  = n_env
+	    , tyid_env   = n_env
+	    , meth_env   = Env.newEnv
+	    , iso_meths  = Env.newEnv
+	    , meth_offset = Nothing
+	    , iface_env  = ienv
+	    , iface_nuke_env = Env.newEnv
+	    }
+
+\end{code}
+
+\begin{code}
+lookupTypeId :: Name -> RnM (Maybe (Maybe String, Type))
+lookupTypeId nm = RnM $ \ _ st -> 
+  ( mapMb (\ (mod,t,_) -> (mod,t))
+          (Env.lookupEnv (type_env st) nm)
+  , st
+  )
+
+lookupIface :: Name -> RnM (Maybe Decl)
+lookupIface nm = RnM ( \ _ st -> (Env.lookupEnv (iface_env st) nm, st))
+
+lookupTag :: Name -> RnM (Maybe (Maybe String, String))
+lookupTag nm = RnM ( \ _ st -> (Env.lookupEnv (tg_env st) nm, st))
+
+getMethOffset :: RnM (Maybe Int)
+getMethOffset = RnM ( \ _ st -> (meth_offset st, st))
+
+setMethOffset :: Maybe Int -> RnM a -> RnM a
+setMethOffset no (RnM a) = RnM ( \ env st -> a env (st{meth_offset=no}))
+
+incMethOffset :: RnM ()
+incMethOffset = RnM $ \ _ st -> 
+	    let
+	      st' =
+	       case meth_offset st of
+	         Nothing -> st
+		 Just x  -> st{meth_offset=Just (x+1)}
+	    in
+	    ((), st')
+
+withNewVarIdEnv :: RnM a -> RnM a
+withNewVarIdEnv (RnM act) = RnM $ \ env st -> 
+     let old = varid_env st in
+     case act env st of
+       (v, st') -> (v, st'{varid_env=old})
+
+inNewModule :: RnM a -> RnM a
+inNewModule (RnM act) = RnM $ \ env st ->
+   let
+    ds   = tycon_env st
+    vs   = varid_env st
+    ts   = tyid_env st
+   in
+   case act env st of
+     (v, new_st) -> (v, new_st{tycon_env=ds,varid_env=vs,tyid_env=ts})
+
+isSourceIface :: Name -> RnM Bool
+isSourceIface nm =
+  RnM ( \ _ st -> (isJust (Env.lookupEnv (src_env st) nm), st))
+
+newINameEnv :: NameEnv
+newINameEnv = Env.newEnv
+
+newNameEnv :: UniqueNameEnv
+newNameEnv = Env.addListToEnv Env.newEnv builtins
+ where
+  builtins = zip builtin_names (repeat 0)
+  
+  builtin_names = haskellKeywords
+
+haskellKeywords :: [String]
+haskellKeywords =
+ [ "case", "class", "data", "default", "deriving", "do"
+ , "else", "if", "import", "in", "infix", "infixl", "infixr"
+ , "instance", "let", "module", "newtype", "of", "then", "type", "where"
+ , "do"
+ , "as", "qualified", "hiding" -- special ids the last three, so strictly not necessary to include them.
+ ]
+
+lookupAndAddEnv2 :: (RnState -> NameSpaceEnv)
+		 -> (RnState -> NameSpaceEnv -> RnState)
+		 -> String 
+		 -> String
+		 -> (String -> RnM a) 
+		 -> RnM a
+lookupAndAddEnv2 get upd nm nm_to_use cont = RnM $ \ rn_env st ->
+        let (fwdMap, idlMap, env) = get st in
+	case Env.lookupEnv fwdMap nm of
+	  Just x -> -- a mention has already been made of this IDL name in
+	  	    -- this scope, just reuse it.
+		let
+		 (RnM act) = cont x
+		in
+		act rn_env st
+          Nothing -> -- no forward mention, try the IDL->HS map.
+	     case Env.lookupEnv idlMap nm of
+	       Just x -> -- IDL name in scope, use it's unique name. 
+	       		let
+	                 (RnM act) = cont x
+			in
+			act rn_env st
+	       Nothing ->
+	           -- Not seen, add it to the 'forward map', allocating
+		   -- a unique name for it.
+		case Env.lookupEnv env nm_to_use of
+	          Nothing -> 
+	            let env'      = Env.addToEnv env nm_to_use 0
+		    	fwdMap'   = Env.addToEnv fwdMap nm nm_to_use
+	                (RnM act) = cont nm_to_use
+		    in
+		    act rn_env (upd st (fwdMap', idlMap, env'))
+	          Just i -> 
+		    -- Find a new unique and use it.
+	           let 
+		       (env',nm') = addNewName env nm_to_use i
+		       fwdMap'    = Env.addToEnv fwdMap nm nm'
+	               (RnM act)  = cont nm'
+		   in
+		   act rn_env (upd st (fwdMap',idlMap,env'))
+
+lookupAndAddEnv :: (RnState -> NameSpaceEnv)
+		 -> (RnState -> NameSpaceEnv -> RnState)
+		 -> String 
+		 -> String
+		 -> (String -> RnM a) 
+		 -> RnM a
+lookupAndAddEnv get upd nm nm_to_use cont = RnM $ \ rn_env st ->
+        let (fwdMap,idlMap, env) = get st in
+	case Env.lookupEnv fwdMap nm of
+	  Just x -> -- a mention has been made of this IDL name in
+	  	    -- this scope, incorporate it in the 'IDL map'
+		    -- and remove it from the 'forward map'.
+		case Env.lookupEnv env x of
+		    -- This case could should never happen, as the
+		    -- addition of a name to the 'forward map' will
+		    -- have allocated a unique name using 'env'. (It's
+		    -- no problem to handle it correctly though.)
+		  Nothing -> let
+		              env'      = Env.addToEnv env x 0
+			      fwdMap'   = Env.delFromEnv fwdMap nm
+			      idlMap'   = Env.addToEnv idlMap nm x
+			      (RnM act) = cont x
+			     in
+			     act rn_env (upd st (fwdMap',idlMap', env'))
+		  Just _ -> 
+		    -- 
+	           let 
+		       fwdMap'   = Env.delFromEnv fwdMap nm
+		       idlMap'   = Env.addToEnv idlMap nm x
+	               (RnM act) = cont x
+		   in
+		   act rn_env (upd st (fwdMap',idlMap',env))
+          Nothing -> -- there's been no forward reference, 
+	  	     -- 'simply' find a unique name and upd. the IDL map.
+	     case Env.lookupEnv env nm_to_use of
+	        Nothing -> 
+	          let env'       = Env.addToEnv env nm_to_use 0
+		      idlMap'    = Env.addToEnv idlMap nm nm_to_use
+	              (RnM act)  = cont nm_to_use
+		  in
+		  act rn_env (upd st (fwdMap, idlMap', env'))
+	        Just i -> 
+	           let (env',nm') = addNewName env nm_to_use i
+		       idlMap'    = Env.addToEnv idlMap nm nm'
+	               (RnM act)  = cont nm'
+		   in
+		   act rn_env (upd st (fwdMap,idlMap',env'))
+
+addNewName :: Env.Env String Int
+           -> String
+	   -> Int
+	   -> (Env.Env String Int, String)
+addNewName env nm v =
+  let nm' = nm ++ show v in
+  case Env.lookupEnv env nm' of
+   Nothing -> 
+	      let env'     = Env.addToEnv env  nm  (v+1)
+	          env''    = Env.addToEnv env' nm' 0
+              in
+	      (env'', nm')
+   Just _  -> addNewName env nm (v+1)
+
+
+lookupVarIdAndAddEnv :: String -> (String -> RnM a) -> RnM a
+lookupVarIdAndAddEnv nm cont = 
+    lookupAndAddEnv (varid_env) (\ st env' -> st{varid_env=env'}) nm (mkHaskellVarName nm) cont
+
+lookupTypeIdAndAddEnv :: String -> (String -> RnM a) -> RnM a
+lookupTypeIdAndAddEnv nm cont = 
+    lookupAndAddEnv (tyid_env) (\ st env' -> st{tyid_env=env'}) nm (mkHaskellTyConName nm) cont
+
+lookupTyConAndAddEnv :: String -> (String -> RnM a) -> RnM a
+lookupTyConAndAddEnv nm cont = 
+    lookupAndAddEnv (tycon_env) (\ st env' -> st{tycon_env=env'}) nm (mkHaskellTyConName nm) cont
+
+lookupModIdAndAddEnv :: String -> (String -> RnM a) -> RnM a
+lookupModIdAndAddEnv nm cont = 
+    lookupAndAddEnv (modid_env) (\ st env' -> st{modid_env=env'}) nm (mkHaskellTyConName nm) cont
+
+lookupClassIdAndAddEnv :: String -> (String -> RnM a) -> RnM a
+lookupClassIdAndAddEnv nm cont = 
+    lookupAndAddEnv (clsid_env) (\ st env' -> st{clsid_env=env'}) nm (mkHaskellTyConName nm) cont
+
+lookupTyConEnv :: String -> (String -> RnM a) -> RnM a
+lookupTyConEnv nm cont = 
+    lookupAndAddEnv2 (tycon_env) (\ st env' -> st{tycon_env=env'}) nm (mkHaskellTyConName nm) cont
+
+lookupTypeIdEnv :: String -> (String -> RnM a) -> RnM a
+lookupTypeIdEnv nm cont = 
+    lookupAndAddEnv2 (tyid_env) (\ st env' -> st{tyid_env=env'}) nm (mkHaskellTyConName nm) cont
+
+lookupVarIdEnv :: String -> (String -> RnM a) -> RnM a
+lookupVarIdEnv nm cont = 
+    lookupAndAddEnv2 (varid_env) (\ st env' -> st{varid_env=env'}) nm (mkHaskellVarName nm) cont
+
+varIdInScope :: String -> RnM Bool
+varIdInScope nm = RnM $ \ _ st ->
+   let (_,idlMap, env) = varid_env st in
+   case Env.lookupEnv idlMap nm of
+     Nothing -> (isJust (Env.lookupEnv env nm), st)
+     Just _  -> (True, st)
+
+addIface :: String -> Decl -> RnM ()
+addIface nm d = RnM (\ _ st -> ((), st{iface_env=Env.addToEnv (iface_env st) nm d}))
+
+addNukeIface :: String -> Id -> RnM ()
+addNukeIface nm i =
+    RnM
+      (\ _ st ->
+	case Env.lookupEnv (iface_nuke_env st) nm of
+	   Nothing -> ((), st{iface_nuke_env=Env.addToEnv (iface_nuke_env st) nm (Just i)})
+	   Just _  -> ((), st{iface_nuke_env=Env.addToEnv (iface_nuke_env st) nm Nothing}))
+
+addMethod :: String -> (Maybe Int, Result, [Param]) -> RnM ()
+addMethod nm it = RnM (\ _ st -> ((), st{meth_env=Env.addToEnv_C (++) (meth_env st) nm [it]}))
+
+addIsoMethod :: String -> (Result,[Param]) -> RnM ()
+addIsoMethod nm it =
+   RnM (\ _ st -> 
+	  ((), st{iso_meths=Env.addToEnv_C (++) (iso_meths st) nm [it]}))
+
+lookupMethod :: String -> RnM (Maybe [(Maybe Int, Result, [Param])])
+lookupMethod nm = RnM (\ _ st -> (Env.lookupEnv (meth_env st) nm, st))
+
+setIfaceName :: String -> RnM a -> RnM a
+setIfaceName nm (RnM act) = RnM (\ (_,hmod,ls) st -> act (nm,hmod,ls) st)
+
+setModuleName :: String -> RnM a -> RnM a
+setModuleName nm (RnM act) = RnM (\ (inm,_,ls) st -> act (inm,nm,ls) st)
+
+withDependers :: [String] -> RnM a -> RnM a
+withDependers nms (RnM act) = RnM (\ (inm,nm,_) st -> act (inm,nm,nms) st)
+
+getIfaceName :: (String -> RnM a) -> RnM a
+getIfaceName f = RnM (\ env@(nm,_,_) st -> let (RnM act) = f nm in act env st)
+
+getModuleName :: (String -> RnM a) -> RnM a
+getModuleName f = RnM (\ env@(_,nm,_) st -> let (RnM act) = f nm in act env st)
+
+getDependers :: ([String] -> RnM a) -> RnM a
+getDependers f = RnM (\ env@(_,_,nms) st -> let (RnM act) = f nms in act env st)
+
+\end{code}
+
+And, finally, let's have a look at tomorrow's weather..
+
+\begin{code}
+instance Monad RnM where
+  (>>=) (RnM m) n =
+     RnM (\ env st ->
+            case m env st of
+	      (v, st') -> let (RnM act) = n v in
+	                   act env st')
+  return v = RnM (\ _ st -> (v,st))
+
+\end{code}
+ src/Skeleton.lhs view
@@ -0,0 +1,154 @@+%
+% (c) Sigbjorn Finne, 1999
+%
+
+Generation skeleton implementations of Haskell
+servers:
+
+\begin{code}
+module Skeleton where
+
+import AbstractH ( HDecl, HTopDecl )
+import MarshallCore
+import MarshallUtils
+import MkImport
+import AbsHUtils
+import CoreIDL
+import CoreUtils
+import Attribute
+import LibUtils
+
+import List ( partition )
+
+\end{code}
+
+Top-level chap, one skeleton per coclass.
+
+\begin{code}
+cgSkeleton :: [Decl] -> [(String, Bool, [HTopDecl])]
+cgSkeleton decls = map genSkeleton coclasses_only
+  where
+   coclasses_only = filter isCoClass (reallyFlattenDecls decls)
+\end{code}
+
+\begin{code}
+genSkeleton :: Decl -> (String, Bool, [HTopDecl])
+genSkeleton (CoClass cid ds) = 
+  ( name ++ ".hs"
+  , False
+  , [hModule name False exports imports mod_decls]
+  )
+ where
+  exports   = []
+  imports   = map (\ (nm,f,ls) -> hImport nm f ls)
+  		  (mkImportLists name (getHsImports cid) [mod_decls])
+
+  mod_decls = 
+          obj_state_decl           `andDecl`
+	  new_decl		   `andDecl`
+          andDecls prop_selectors  `andDecl`
+	  andDecls stub_meths
+
+  (props,meths)	= partition isProperty coclass_decls
+  coclass_decls = filter (isMethodOrProp) (concat (map (getDecls) ds))
+
+  name		= mkHaskellTyConName (idName cid)
+
+  prop_selectors = map mkPropSelect props
+  stub_meths	 = map mkStubMethod meths
+  
+  getDecls (CoClassInterface     _ (Just (Interface _ _ _ decls))) = decls
+  getDecls (CoClassDispInterface _ (Just (DispInterface _ (Just (Interface{declDecls=decls})) _ _))) = decls
+  getDecls (CoClassDispInterface _ (Just (DispInterface _ _ ps ms))) = ps ++ ms
+  getDecls _ = []
+
+  new_decl = new_tysig `andDecl` new_def
+  new_nm    = "new"
+  new_tysig = typeSig new_nm (io obj_ty)
+  new_def   = valDef new_nm (ret (dataConst (mkQConName Nothing obj_dc)))
+
+  obj_nm         = mkHaskellTyConName (idName cid)
+  obj_state_decl = dataTy obj_dc [] [recConBanged obj_dc fields]
+  obj_dc         = "State"
+  obj_ty	 = tyConst "State"
+
+  fields = map mkField props
+  mkField (Property propId ty _ _ _) = 
+    ("prop"++idName propId, tyQCon ioExts "IORef" [toHaskellTy False ty])
+  mkField _ = error "Skeleton.genSkeleton.mkField: it only groks Properties"
+
+
+  mkPropSelect (Property i ty _ seti geti)
+     | attrs `hasAttributeWithName` "readonly" = getter
+     | otherwise			       = getter `andDecl` setter
+    where
+     attrs         = idAttributes i
+     getter	   = mkPropGet seti ty
+     setter	   = mkPropSet geti ty
+  mkPropSelect (Method i _ res _ _) 
+     | attrs `hasAttributeWithName` "propget" = getter
+     | otherwise			      = setter
+    where
+     ty		   = resultType res --toHaskellMethodTy (Just (tyConst name)) ps res
+     attrs         = idAttributes i
+     getter	   = mkPropGet i ty
+     setter	   = mkPropSet i ty
+  mkPropSelect _ = error "Skeleton.genSkeleton.mkPropSelect: it only groks Properties and Methods"
+
+  mkPropGet i ty   = getter
+   where
+     prop_ty       = toHaskellTy False ty
+     prop_field_nm = "prop"++idName i
+     getter        = get_tysig `andDecl` get_def
+     get_tysig     = typeSig get_name get_type
+     get_name      = mkHaskellTyConName (idName i)
+     get_type      = funTy obj_ty (io prop_ty)
+     get_def       = funDef get_name [patRec (mkVarName obj_nm) 
+					  [(mkVarName prop_field_nm, patVar prop_field_nm)]]
+			 get_rhs
+     get_rhs    = funApp (mkQVarName ioExts "readIORef") [var prop_field_nm]
+
+  mkPropSet i ty = setter
+    where
+     prop_ty    = toHaskellTy False ty
+     prop_field_nm = "prop"++idName i
+     setter     = set_tysig `andDecl` set_def
+     set_tysig  = typeSig set_name set_type
+     set_name   = mkHaskellTyConName (idName i)
+     set_type   = funTy prop_ty (funTy obj_ty io_unit)
+     set_def    = funDef set_name [ patVar "val___"
+				  , patRec (mkVarName obj_nm) 
+				           [ (mkVarName prop_field_nm
+					   , patVar prop_field_nm)
+					   ]
+				  ]
+			 set_rhs
+     set_rhs    = funApp (mkQVarName ioExts "writeIORef") [var prop_field_nm, var "val___"]
+
+genSkeleton _ = error "Skeleton.genSkeleton: can only generate code skeletons from coclasses"
+
+mkStubMethod :: Decl -> HDecl
+mkStubMethod (Method i _ res ps _) =
+   stub_tysig `andDecl`
+   stub_def
+ where
+   name		   = mkHaskellVarName (idName i)
+
+   stub_tysig        = genTypeSig name mb_c stub_type
+   stub_def          = funDef name stub_in_pats stub_rhs
+   (stub_type, mb_c) = toHaskellMethodTy isPure
+   					 True {- is server -}
+					 False
+                                         (Just (tyConst "State"))
+				         ps res
+   isPure          = (idAttributes i) `hasAttributeWithName` "pure"
+   stub_rhs        = funApply (varName prelError) [stringLit "Your code goes here"]
+   stub_in_pats    = map (varPat.mkHVar.paramId) meth_params
+
+   (pars, _, _, _, _) = binParams ps
+   meth_params	      = real_params ++ [obj_param]
+   (real_params, _)   = findParamDependents False pars
+   obj_param          = objParam (idName i)
+mkStubMethod _ = error "Skeleton.mkStubMethod: it only groks Methods"
+\end{code}
+
+ src/SrcLoc.lhs view
@@ -0,0 +1,50 @@+%
+% @(#) $Docid: Nov. 2nd 2000  13:43  Sigbjorn Finne $
+% @(#) $Contactid: sof@microsoft.com $
+%
+
+\begin{code}
+module SrcLoc 
+       (
+          SrcLoc
+        , mkSrcLoc
+	, modSrcLoc
+	, dummySrcLoc
+        , incSrcLineNo
+        , ppSrcLoc
+	) where
+
+import PP
+\end{code}
+
+\begin{code}
+data SrcLoc
+ = SrcLoc String  -- module name
+          Int     -- line number
+          
+ | NoSrcLoc
+
+mkSrcLoc :: String -> Int -> SrcLoc
+mkSrcLoc = SrcLoc
+
+modSrcLoc :: SrcLoc -> String
+modSrcLoc (SrcLoc s _) = s
+modSrcLoc NoSrcLoc     = error "SrcLoc.modSrcLoc: tried to get the module of a NoSrcLoc"
+
+dummySrcLoc :: SrcLoc
+dummySrcLoc = NoSrcLoc
+
+incSrcLineNo :: SrcLoc -> SrcLoc
+incSrcLineNo NoSrcLoc = NoSrcLoc
+incSrcLineNo (SrcLoc mod l) = SrcLoc mod (l+1)
+\end{code}
+
+\begin{code}
+ppSrcLoc :: SrcLoc -> PPDoc a
+ppSrcLoc (SrcLoc mod lno) = text mod <> char ':' <> int lno
+ppSrcLoc NoSrcLoc = text "<unknown module, unknown line>"
+
+instance Show SrcLoc where 
+  showsPrec _ loc = \ str -> (showPPDoc (ppSrcLoc loc) undefined) ++ str
+
+\end{code}
+ src/SymbolTable.lhs view
@@ -0,0 +1,63 @@+%
+%
+%
+
+A symbol table abstraction that stores keywords as separate from
+user defined type IDs.
+
+\begin{code}
+module SymbolTable 
+
+       (
+         SymbolTable
+       , mkSymbolTable   -- :: [(String, tok)] -> SymbolTable tok
+       , newContext      -- :: SymbolTable tok -> SymbolTable tok
+       , lookupSymbol    -- :: SymbolTable tok -> String -> Maybe tok
+       , lookupType      -- :: SymbolTable tok -> String -> Maybe tok
+
+       , addType         -- :: SymbolTable tok -> String -> tok -> SymbolTable tok
+       , addKeyword      -- :: SymbolTable tok -> String -> tok -> SymbolTable tok
+
+       , combineSyms     -- :: SymbolTable tok -> SymbolTable tok -> SymbolTable tok
+
+       ) where
+
+import FiniteMap
+
+\end{code}
+
+\begin{code}
+data SymbolTable elt =
+  SymbolTable 
+    (FiniteMap String elt)   -- keywords
+    (FiniteMap String elt)   -- user defined types (via typedef.)
+
+mkSymbolTable :: [(String,tok)] -> SymbolTable tok
+mkSymbolTable ls = SymbolTable (listToFM ls) emptyFM
+
+newContext :: SymbolTable tok -> SymbolTable tok
+newContext (SymbolTable keyw _) = SymbolTable keyw emptyFM
+
+combineSyms :: SymbolTable tok -> SymbolTable tok -> SymbolTable tok
+combineSyms (SymbolTable kw1 ty1) (SymbolTable _ ty2) =
+  -- at the moment, we consider the kw bit to be constant.
+  SymbolTable kw1 (plusFM ty1 ty2)
+
+addKeyword :: SymbolTable tok -> String -> tok -> SymbolTable tok
+addKeyword (SymbolTable kw ty) str tok =
+ SymbolTable (addToFM kw str tok) ty
+
+addType :: SymbolTable tok -> String -> tok -> SymbolTable tok
+addType (SymbolTable kw ty) str tok =
+ SymbolTable kw (addToFM ty str tok)
+
+lookupSymbol :: SymbolTable tok -> String -> Maybe tok
+lookupSymbol (SymbolTable kw ty) str = 
+  case lookupFM kw str of
+    Nothing -> lookupFM ty str
+    v       -> v
+
+lookupType :: SymbolTable tok -> String -> Maybe tok
+lookupType (SymbolTable _ ty) str = lookupFM ty str
+
+\end{code}
+ src/TLBWriter.lhs view
@@ -0,0 +1,1196 @@+% 
+% (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}
+ src/TypeInfo.lhs view
@@ -0,0 +1,326 @@+%
+%
+%
+
+Specifying type / marshalling information
+
+\begin{code}
+module TypeInfo 
+
+       ( TypeInfo(..)
+       , typeInfos
+
+       , v_bool_ti
+       , variant_ti
+       , mb_currency_ti
+       , mb_date_ti
+       , guid_ti
+       , iid_ti
+       , clsid_ti
+       , bstr_ti
+
+       ) where
+
+import BasicTypes
+import NativeInfo
+import Opts
+import Maybe
+import AbsHUtils
+import AbstractH ( Type )
+import LibUtils  ( comLib )
+{- BEGIN_SUPPORT_TYPELIBS
+import
+       Automation ( VARENUM(..) )
+   END_SUPPORT_TYPELIBS -}
+
+\end{code}
+
+A @TypeInfo@ record contains all the info needed by the
+backend(s) to convert the use of a type into appropriate
+Haskell code. 
+
+\begin{code}
+data TypeInfo 
+ = TypeInfo {
+     type_name        :: String,
+     haskell_type     :: QualName,
+     marshaller       :: QualName,
+     copy_marshaller  :: QualName,
+     unmarshaller     :: QualName,
+     ref_marshaller   :: QualName,
+     ref_unmarshaller :: QualName,
+     alloc_type       :: Maybe QualName,
+     free_type        :: Maybe QualName,
+     prim_type	      :: Type,
+     c_type           :: String,
+     prim_size        :: QualName,
+     prim_sizeof      :: Int,
+     prim_align       :: Int,
+     auto_type        :: QualName,
+{- BEGIN_SUPPORT_TYPELIBS
+     auto_vt          :: Maybe VARENUM,
+   END_SUPPORT_TYPELIBS -}
+     is_pointed	      :: Bool,
+     finalised	      :: Bool,
+     attributes       :: Maybe String
+   }
+   deriving ( Show, Eq )
+
+\end{code}
+
+\begin{code}
+typeInfos :: [TypeInfo]
+typeInfos = 
+  [ variant_ti
+  , v_bool_ti
+  , currency_ti
+  , iid_ti
+  , clsid_ti
+  , guid_ti
+  ]
+
+iid_ti :: TypeInfo
+iid_ti =
+    TypeInfo 
+        { type_name        = "IID"
+	, haskell_type     = toQualName "Com.IID a"
+	, marshaller       = toQualName "Com.marshallIID"
+	, copy_marshaller  = toQualName "Com.copyIID"
+	, unmarshaller     = toQualName "Com.unmarshallIID"
+	, ref_marshaller   = toQualName "Com.writeIID"
+	, ref_unmarshaller = toQualName "Com.readIID"
+	, alloc_type       = Nothing
+	, free_type        = Nothing
+	, prim_type	   = tyForeignPtr (tyQCon comLib "IID" [uniqueTyVar "a"])
+	, c_type           = "IID*"
+	, auto_type	   = toQualName "Com.IID a"
+	, prim_size        = toQualName "Com.sizeofIID"
+	, prim_sizeof      = 16
+	, prim_align       = 4
+{- BEGIN_SUPPORT_TYPELIBS
+	, auto_vt	   = Nothing
+   END_SUPPORT_TYPELIBS -}
+	, is_pointed	   = True
+	, finalised	   = True
+	, attributes	   = Nothing
+	}
+
+clsid_ti :: TypeInfo
+clsid_ti = 
+  TypeInfo 
+        { type_name        = "CLSID"
+	, haskell_type     = toQualName "Com.CLSID"
+	, marshaller       = toQualName "Com.marshallCLSID"
+	, copy_marshaller  = toQualName "Com.copyCLSID"
+	, unmarshaller     = toQualName "Com.unmarshallCLSID"
+	, ref_marshaller   = toQualName "Com.writeCLSID"
+	, ref_unmarshaller = toQualName "Com.readCLSID"
+	, alloc_type       = Nothing
+	, free_type        = Nothing
+	, prim_type	   = tyForeignPtr (tyQConst comLib "CLSID")
+	, c_type           = "CLSID*"
+	, auto_type	   = toQualName "Com.CLSID"
+	, prim_size        = toQualName "Com.sizeofCLSID"
+	, prim_sizeof      = 16
+	, prim_align       = 4
+{- BEGIN_SUPPORT_TYPELIBS
+	, auto_vt	   = Nothing
+   END_SUPPORT_TYPELIBS -}
+	, is_pointed	   = True
+	, finalised	   = True
+	, attributes	   = Nothing
+	}
+
+guid_ti :: TypeInfo
+guid_ti = 
+  TypeInfo 
+        { type_name        = "GUID"
+	, haskell_type     = toQualName "Com.GUID"
+	, marshaller       = toQualName "Com.marshallGUID"
+	, copy_marshaller  = toQualName "Com.copyGUID"
+	, unmarshaller     = toQualName "Com.unmarshallGUID"
+	, ref_marshaller   = toQualName "Com.writeGUID"
+	, ref_unmarshaller = toQualName "Com.readGUID"
+	, alloc_type       = Nothing
+	, free_type        = Nothing
+	, prim_type	   = tyForeignPtr (tyQConst comLib "GUID")
+	, c_type           = "GUID*"
+	, auto_type	   = toQualName "Com.GUID"
+	, prim_size        = toQualName "Com.sizeofGUID"
+	, prim_sizeof      = 16
+	, prim_align       = 4
+{- BEGIN_SUPPORT_TYPELIBS
+	, auto_vt	   = Nothing
+   END_SUPPORT_TYPELIBS -}
+	, is_pointed	   = True
+	, finalised	   = True
+	, attributes	   = Nothing
+	}
+
+mb_currency_ti :: Maybe TypeInfo
+mb_currency_ti = Just currency_ti
+
+currency_ti :: TypeInfo
+currency_ti = 
+  TypeInfo 
+        { type_name        = "CURRENCY"
+	, haskell_type     = toQualName "Automation.Currency"
+	, marshaller       = toQualName "Automation.marshallCurrency"
+	, copy_marshaller  = toQualName "Automation.marshallCurrency"
+	, unmarshaller     = toQualName "Automation.unmarshallCurrency"
+	, ref_marshaller   = toQualName "Automation.writeCurrency"
+	, ref_unmarshaller = toQualName "Automation.readCurrency"
+	, alloc_type       = Nothing
+	, free_type        = Nothing
+	, prim_type	   = tyInt64
+	, c_type           = "CURRENCY"
+	, auto_type	   = toQualName "Automation.Currency"
+	, prim_size        = toQualName "HDirect.sizeofInt64"
+	, prim_sizeof      = lONGLONG_SIZE
+	, prim_align       = lONGLONG_ALIGN_MODULUS
+{- BEGIN_SUPPORT_TYPELIBS
+	, auto_vt	   = Just VT_CY
+   END_SUPPORT_TYPELIBS -}
+	, is_pointed	   = False
+	, finalised	   = False
+	, attributes	   = Nothing
+	}
+
+mb_date_ti :: Maybe TypeInfo
+mb_date_ti = Just date_ti
+
+date_ti :: TypeInfo
+date_ti = 
+  TypeInfo 
+        { type_name        = "DATE"
+	, haskell_type     = toQualName "Automation.Date"
+	, marshaller       = toQualName "HDirect.marshallDouble"
+	, copy_marshaller  = toQualName "HDirect.marshallDouble"
+	, unmarshaller     = toQualName "HDirect.unmarshallDouble"
+	, ref_marshaller   = toQualName "HDirect.writeDouble"
+	, ref_unmarshaller = toQualName "HDirect.readDouble"
+	, alloc_type       = Nothing
+	, free_type        = Nothing
+	, prim_type	   = tyDouble
+	, c_type           = "double"
+	, auto_type	   = toQualName "Automation.Date"
+	, prim_size        = toQualName "HDirect.sizeofDouble"
+	, prim_sizeof      = dOUBLE_SIZE
+	, prim_align       = dOUBLE_ALIGN_MODULUS
+{- BEGIN_SUPPORT_TYPELIBS
+	, auto_vt	   = Just VT_DATE
+   END_SUPPORT_TYPELIBS -}
+	, is_pointed	   = False
+	, finalised	   = False
+	, attributes	   = Nothing
+	}
+
+variant_ti :: TypeInfo
+variant_ti 
+  | optNoOverloadVariant || optServer =
+    TypeInfo 
+        { type_name        = "VARIANT"
+	, haskell_type     = toQualName "Automation.VARIANT"
+	, marshaller       = toQualName "Automation.marshallVARIANT"
+	, copy_marshaller  = toQualName "Automation.copyVARIANT"
+	, unmarshaller     = toQualName "Automation.unmarshallVARIANT"
+	, ref_marshaller   = toQualName "Automation.writeVARIANT"
+	, ref_unmarshaller = toQualName "Automation.readVARIANT"
+	, alloc_type       = Just (toQualName "Automation.allocVARIANT")
+	, free_type        = Nothing
+	, prim_type	   = {-tyPtr-} (mkTyConst $ toQualName "Automation.VARIANT")
+	, c_type           = "VARIANT"
+	, auto_type	   = toQualName "a"
+	, prim_size        = toQualName "Automation.sizeofVARIANT"
+	, prim_sizeof      = 16
+	, prim_align       = 8
+{- BEGIN_SUPPORT_TYPELIBS
+	, auto_vt	   = Just VT_VARIANT
+   END_SUPPORT_TYPELIBS -}
+	, is_pointed	   = True
+	, finalised	   = False
+	, attributes	   = Nothing
+	}
+  | otherwise =
+    TypeInfo 
+        { type_name        = "VARIANT"
+	, haskell_type     = toQualName "a"  -- magic.
+	, marshaller       = toQualName "Automation.marshallVariant"
+	, copy_marshaller  = toQualName "Automation.marshallVariant"
+	, unmarshaller     = toQualName "Automation.unmarshallVariant"
+	    -- Note: when we're marshalling Variants by reference, this
+	    --       is only done for constructed types, so we want to use
+	    --       the non-overloaded VARIANT marshallers rather than
+	    --       the overloaded (since VARIANTs embedded inside a
+	    --       constructed type is represented by VARIANT.)
+	, ref_marshaller   = toQualName "Automation.writeVARIANT"
+	, ref_unmarshaller = toQualName "Automation.readVARIANT"
+	, alloc_type       = Just (toQualName "Automation.allocVARIANT")
+	, free_type        = Nothing
+	, prim_type	   = {-tyPtr-} (mkTyConst $ toQualName "Automation.VARIANT")
+	, c_type           = "VARIANT"
+	, auto_type	   = toQualName "a"
+	, prim_size        = toQualName "Automation.sizeofVARIANT"
+	, prim_sizeof      = 16
+	, prim_align       = 8
+{- BEGIN_SUPPORT_TYPELIBS
+	, auto_vt	   = Just VT_VARIANT
+   END_SUPPORT_TYPELIBS -}
+	, is_pointed	   = True
+	, finalised	   = False
+	, attributes	   = Nothing
+	}
+
+v_bool_ti :: TypeInfo
+v_bool_ti = 
+  TypeInfo 
+        { type_name        = "VARIANT_BOOL"
+	, haskell_type     = toQualName "Prelude.Bool"
+	, marshaller       = toQualName "Automation.marshallVARIANT_BOOL"
+	, copy_marshaller  = toQualName "Automation.marshallVARIANT_BOOL"
+	, unmarshaller     = toQualName "Automation.unmarshallVARIANT_BOOL"
+	, ref_marshaller   = toQualName "Automation.writeVARIANT_BOOL"
+	, ref_unmarshaller = toQualName "Automation.readVARIANT_BOOL"
+	, alloc_type       = Nothing
+	, free_type        = Nothing
+	, prim_type	   = tyInt16
+	, c_type           = "VARIANT_BOOL"
+	, auto_type        = toQualName "Prelude.Bool"
+	, prim_size        = toQualName "HDirect.sizeofInt16"
+	, prim_sizeof      = sHORT_SIZE
+	, prim_align       = sHORT_ALIGN_MODULUS
+{- BEGIN_SUPPORT_TYPELIBS
+	, auto_vt	   = Nothing
+   END_SUPPORT_TYPELIBS -}
+	, is_pointed	   = False
+	, finalised	   = False
+	, attributes	   = Nothing
+	}
+
+bstr_ti :: TypeInfo
+bstr_ti = 
+  TypeInfo 
+        { type_name        = "BSTR"
+	, haskell_type     = toQualName "Prelude.String"
+	, marshaller       = toQualName "Com.marshallBSTR"
+	, copy_marshaller  = toQualName "Com.marshallBSTR"
+	, unmarshaller     = toQualName "Com.unmarshallBSTR"
+	, ref_marshaller   = toQualName "Com.writeBSTR"
+	, ref_unmarshaller = toQualName "Com.readBSTR"
+	, alloc_type       = Nothing
+	, free_type        = Just (toQualName "Com.freeBSTR")
+	, prim_type	   = tyPtr tyString
+	, c_type           = "void*"
+	, auto_type        = toQualName "Prelude.String"
+	, prim_size        = toQualName "HDirect.sizeofPtr"
+	, prim_sizeof      = dATA_PTR_SIZE
+	, prim_align       = dATA_PTR_ALIGN_MODULUS
+{- BEGIN_SUPPORT_TYPELIBS
+	, auto_vt	   = Just VT_BSTR
+   END_SUPPORT_TYPELIBS -}
+	, is_pointed	   = False
+	, finalised	   = False
+	, attributes	   = Nothing
+	}
+
+\end{code}
+ src/Utils.lhs view
@@ -0,0 +1,397 @@+%
+% @(#) $Docid: Mar. 31th 2003  08:33  Sigbjorn Finne $
+% @(#) $Contactid: sof@galois.com $
+%
+
+\begin{code}
+module Utils 
+       ( showOct
+       , showHex
+       , mapFromMb
+       , mapMb
+       , mapMbM
+       , concMaybe
+       , toMaybe
+       , split
+       , splitLast
+       , splitLastBy
+       , prefix
+       , traceIf
+       , elemBy
+       , mapUnzip
+       , diff
+
+       , deEscapeString
+       , ( # )
+
+       --,UNUSED: catMapMaybes
+       
+       , dropSuffix
+
+         -- re-exported
+       , trace
+       
+       , tryOpen
+       
+       , basename
+       , splitdir
+       , prefixDir
+
+       , hdirect_root
+       , bailIf
+       
+       , decons
+       , safe_init
+       , snoc
+       
+       , mapAccumLM
+       
+       , notNull		-- :: [a] -> Bool
+       
+       ) where
+
+import Char (chr, ord, readLitChar)
+import System.IO
+import IO
+import Int
+{- BEGIN_GHC_ONLY
+import Directory
+   END_GHC_ONLY -}
+import Monad ( when )
+import List  ( mapAccumL, isPrefixOf )
+import Debug.Trace
+
+infixl 1 #
+\end{code}
+
+A convenience operator for invoking methods on objects:
+
+\begin{code}
+( # ) :: a -> (a -> b) -> b
+obj # meth	= meth obj
+\end{code}
+
+Until NumExts is commonly available, we define the following show functions here:
+
+\begin{code}
+showIntAtBase :: Integral a => a -> (a -> Char) -> a -> ShowS
+showIntAtBase base toChr n r
+  | n < 0     = '-':showIntAtBase 10 toChr (negate n) r
+  | otherwise = 
+    case quotRem n base of { (n', d) ->
+    case toChr d        of { ch ->
+    let
+	r' = ch : r
+    in
+    if n' == 0 then r' else showIntAtBase base toChr n' r'
+    }}
+
+showHex :: Integral a => a -> ShowS
+showHex n r = 
+ showString "0x" $
+ showIntAtBase 16 (toChrHex) n r
+ where  
+  toChrHex d
+    | d < 10    = chr (ord_0   + fromIntegral d)
+    | otherwise = chr (ord 'a' + fromIntegral (d - 10))
+
+showOct :: Integral a => a -> ShowS
+showOct n r = 
+ showString "0o" $
+ showIntAtBase 8 (toChrOct) n r
+ where toChrOct d = chr (ord_0   + fromIntegral d)
+
+ord_0 :: Num a => a
+ord_0 = fromIntegral (ord '0')
+\end{code}
+
+Mapping from a Maybe:
+
+\begin{code}
+mapFromMb :: b -> (a -> b) -> Maybe a -> b
+mapFromMb d f mb = case mb of  Nothing -> d ; Just v  -> f v
+\end{code}
+
+\begin{code}
+split :: Eq a => a -> [a] -> [[a]]
+split _ [] = []
+split a as = 
+ case break (==a) as of
+   (xs,[])   -> [xs]
+   (xs,_:ys) -> xs:split a ys
+
+\end{code}
+
+Split at last occurrence of substring.
+
+\begin{code}
+splitLast :: Eq a => [a] -> [a] -> ([a],[a])
+splitLast []         ls = (ls,[])
+splitLast sep@(_:ss) ls = splitLastBy (sep `isPrefixOf`) (drop (length ss)) ls
+
+splitLastBy :: ([a] -> Bool) -- True => current suffix satisifies 
+	    -> ([a] -> [a])  -- for the last match, transform the result coming back.
+	    -> [a]
+	    -> ([a],[a])
+splitLastBy predic munge ls = 
+   case (chomp (-1) (0::Int) ls) of
+     (_,bef,aft) -> (bef,aft)
+ where
+  chomp lst _ []        = (lst, [], [])
+  chomp lst n as@(x:xs) =
+       case chomp new_last_pos (n+1) xs of
+         (last_found, bef, aft) ->
+	    case (compare last_found n) of
+	      GT -> (last_found, x:bef,   aft)
+	      LT -> (last_found, bef  , x:aft)
+	      EQ -> (last_found, bef  ,   munge aft)
+   where
+    new_last_pos
+     | predic as = n
+     | otherwise = lst
+
+\end{code}
+
+
+\begin{code}
+prefix :: Eq a => [a] -> [a] -> Maybe [a] -- what's left
+prefix [] ls = Just ls
+prefix _  [] = Nothing
+prefix (x:xs) (y:ys)
+ | x == y    = prefix xs ys
+ | otherwise = Nothing
+\end{code}
+
+\begin{code}
+traceIf :: Bool -> String -> a -> a
+traceIf True str v = trace str v
+traceIf _ _ v = v
+
+elemBy :: (a -> Bool) -> [a] -> Bool
+elemBy _       []	=  False
+elemBy isEqual (y:ys)	=  isEqual y || elemBy isEqual ys
+
+mapUnzip :: (a -> (b,c)) -> [a] -> ([b],[c])
+mapUnzip _ []     = ([],[])
+mapUnzip f (x:xs) =
+  let
+   (a, b)  = f x
+   (as,bs) = mapUnzip f xs
+  in
+  (a:as,b:bs)
+\end{code}
+
+Returns list of deltas, i.e,
+
+@
+  diff [x0,x1..xp,xn] = [x0, x1-x0, .., xp - xn]
+@
+
+\begin{code}
+diff :: Num a => [a] -> [a]
+diff ls = snd (mapAccumL ( \ acc v -> (v, v - acc)) 0 ls)
+\end{code}
+
+begin{code}
+catMapMaybes :: (a -> b) -> [Maybe a] -> [b]
+catMapMaybes f ls = [f x | Just x <- ls]
+end{code}
+
+Dropping the extension off of a filename:
+
+\begin{code}
+dropSuffix :: String -> String
+dropSuffix str = 
+ case dropWhile (\ch -> ch /= '.' && ch /= '/' && ch /= '\\' ) 
+                (reverse str) of
+      ('.':rs) -> reverse rs
+      _        -> str
+      -- give up if we reach a separator (/ or \) or end of list.
+
+{- UNUSED:
+dropPrefix :: Eq a => [a] -> [a] -> [a]
+dropPrefix []         ys = ys
+dropPrefix _          [] = []
+dropPrefix (x:xs) (y:ys) 
+  | x == y               = dropPrefix xs ys
+  | otherwise            = y:ys
+-}
+\end{code}
+
+Slightly generalised version of code found in GreenCard's front end:
+
+\begin{code}
+tryOpen ::   Bool 
+	 -> [FilePath] 
+	 -> [String] 
+	 -> FilePath
+	 -> IO (Maybe FilePath)
+tryOpen verbose path exts name = 
+  doUntil (mbOpenFile verbose) (allFileNames path name exts)
+
+doUntil :: (a -> IO (Maybe b)) -> [a] -> IO (Maybe b)
+doUntil _     [] = return Nothing
+doUntil f (a:as) = do
+  v <- f a
+  case v of
+   Nothing -> doUntil f as
+   _       -> return v
+
+allFileNames :: [String] -> String -> [String] -> [String]
+allFileNames path file exts 
+  = [addSuffix '/' d ++ file ++ (prefixWith '.' ext) | d <- path, ext <- exts]
+    where
+     addSuffix _  []  = []
+     addSuffix ch ls  = 
+        case (decons ls) of
+	  (_,x)
+	    | x == ch   -> ls
+	    | otherwise -> ls++[ch]
+
+     prefixWith _  [] = []
+     prefixWith ch ls@(x:_)
+       | ch == x   = ls
+       | otherwise = ch:ls
+\end{code}
+
+Combining <tt>last</tt> and <tt>init</tt> into one (pass
+over the list):
+
+\begin{code}
+decons :: [a] -> ([a],a)
+decons ds = trundle ds
+ where
+  trundle []     = error "decons: empty list"
+  trundle [x]    = ([], x)
+  trundle (x:xs) = let (ls, l) = trundle xs in (x:ls, l)
+\end{code}
+
+Try reading a file:
+
+\begin{code}
+
+mbOpenFile :: Bool -> FilePath -> IO (Maybe FilePath)
+mbOpenFile verbose fpath = do
+   -- I seem to remember that Hugs doesn't support Directory...
+{- BEGIN_GHC_ONLY
+  flg <- doesFileExist fpath
+  END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+  flg <- (openFile fpath ReadMode >>= \ h -> hClose h >> return True)
+            `catch` (\ _ -> return False)
+{- END_NOT_FOR_GHC -}
+  if not flg 
+   then return Nothing
+   else do
+     when verbose (hPutStrLn stderr ("Reading file: " ++ show fpath))
+     return (Just fpath)
+
+\end{code}
+
+\begin{code}
+basename :: String -> String
+basename str = snd $
+    splitLastBy (\ (x:_) -> x == '/' || x == '\\')
+    		id
+		str
+     -- bi-lingual, the upshot of which is that
+     -- / isn't allowed in DOS-style paths (and vice
+     -- versa \ isn't allowed in POSIX(?) style pathnames).
+
+splitdir :: String -> (String, String)
+splitdir = 
+  splitLastBy (\ (x:_) -> x == '/' || x == '\\')
+              id
+
+prefixDir :: String -> String -> String
+prefixDir []    rest = rest
+prefixDir ['/'] rest = '/':rest
+prefixDir ['\\'] rest = '/':rest
+prefixDir [x]    rest = x:'/':rest
+prefixDir (x:xs) rest = x : prefixDir xs rest
+
+\end{code}
+
+Removing escape char from double quotes:
+
+\begin{code}
+deEscapeString :: String -> String
+deEscapeString [] = []
+deEscapeString ls@('\\':x:xs) = 
+  case x of
+    '"' -> x : deEscapeString xs -- "
+    _   -> 
+	case readLitChar ls of
+	  ((ch,rs):_) -> ch : deEscapeString rs
+	  _ -> '\\':x: deEscapeString xs
+deEscapeString (x:xs) = x: deEscapeString xs
+\end{code}
+
+The top of the HaskellDirect Registry tree:
+
+\begin{code}
+hdirect_root :: String
+hdirect_root        = "Software\\Haskell\\HaskellDirect"
+
+-- sporadically handy in a monadic context.
+bailIf :: Bool -> a -> a -> a
+bailIf True a _ = a
+bailIf _    _ b = b
+\end{code}
+
+Avoids Haskell version trouble:
+
+\begin{code}
+mapMb :: (a -> b) -> Maybe a -> Maybe b
+mapMb _ Nothing  = Nothing
+mapMb f (Just c) = Just (f c)
+
+mapMbM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b)
+mapMbM _ Nothing  = return Nothing
+mapMbM f (Just c) = f c >>= return.Just
+
+concMaybe :: Maybe a -> Maybe a -> Maybe a
+concMaybe v@(Just _) _ = v
+concMaybe _          v = v
+
+-- If predicate is false, represent it as Nothing.
+toMaybe :: (a -> Bool) -> a -> Maybe a
+toMaybe predic x | predic x  = Nothing
+	         | otherwise = Just x
+\end{code}
+
+\begin{code}
+safe_init :: [a] -> [a]
+safe_init [] = []
+safe_init ls = init ls
+\end{code}
+
+\begin{code}
+snoc :: [a] -> a -> [a]
+snoc []     y = [y]
+snoc (x:xs) y = x : snoc xs y
+\end{code}
+
+\begin{code}
+mapAccumLM :: (Monad m)
+           => (acc -> x -> m (acc, y)) -- Function of elt of input list
+				     -- and accumulator, returning new
+				     -- accumulator and elt of result list
+   	   -> acc	    -- Initial accumulator 
+	   -> [x]	    -- Input list
+	   -> m (acc, [y])	    -- Final accumulator and result list
+mapAccumLM _ s []     	=  return (s, [])
+mapAccumLM f s (x:xs) 	=  do
+ (s', y)     <- f s x
+ (s'',ys)    <- mapAccumLM f s' xs
+ return (s'',y:ys)
+ 
+\end{code}
+
+The simplest of defns; usefule, but not provided as standard:
+
+\begin{code}
+notNull :: [a] -> Bool
+notNull [] = False
+notNull  _ = True
+\end{code}
+ src/Validate.lhs view
@@ -0,0 +1,81 @@+%
+% (c) sof, 1999
+%
+
+Validating fragments of IDL.
+
+\begin{code}
+module Validate 
+	( 
+	  validateParam
+	) where
+
+import CoreIDL
+import CoreUtils
+import BasicTypes
+import Opts
+import TypeInfo
+import Utils
+
+\end{code}
+
+Out parameters need to (expand to) a pointed type. In the
+case of interface pointers, the type has got to be a pointer
+to one.
+
+Errors are treated as warnings (at least for now), so the
+validator will simply notify you of the error of your ways and
+correct the type.
+
+\begin{code}
+validateParam :: String -> Param -> Param
+validateParam msg p =
+  case paramMode p of
+    Out -> 
+      case paramType p of
+       Pointer pt isExp t | optCom && isIfaceTy t && not (isIfacePtr t) ->
+                warnWrongOutParam msg "out"
+				  "pointer to an interface pointer (as it needs to be.)"
+		      		  p{ paramType=(Pointer pt isExp (Pointer Ref True t))
+		       		   , paramOrigType=(Pointer pt isExp (Pointer Ref True t))
+		       		   }
+		   | otherwise -> p
+       t@Iface{} | optCom -> 
+                warnWrongOutParam msg "out"
+				  "pointer to an interface pointer (as it needs to be.)"
+		      		  p{ paramType=(Pointer Ref True (Pointer Ref True t))
+		       		   , paramOrigType=(Pointer Ref True (Pointer Ref True t))
+		       		   }
+       WString{}  -> p
+       String{}   -> p
+       Array{}    -> p
+       Sequence{} -> p
+       Name _ _ _ _ _ (Just ti)
+                   | is_pointed ti -> p
+       t ->
+   	warnWrongOutParam msg "out"
+			  "pointer to a type"
+      		          p{ paramType=Pointer Ref True t
+       		           , paramOrigType=Pointer Ref True (paramOrigType p)
+       		           }
+    In ->
+      case paramType p of
+       ty@Iface{} | optCom -> 
+                warnWrongOutParam msg "in"
+				  "*pointer* to an interface (as it needs to be.)"
+		      		  p{ paramType=(Pointer Ref True ty)
+		       		   , paramOrigType=(Pointer Ref True ty)
+		       		   }
+       _ -> p
+    _ -> p	 		   
+\end{code}
+
+\begin{code}
+warnWrongOutParam :: String -> String -> String -> a -> a
+warnWrongOutParam prefix pkind kind cont =
+   trace ("Warning: [" ++ pkind ++ "] parameter " ++ show prefix ++
+	  " is not a " ++ kind ++ "\n Correcting it for you.\n")
+	 cont
+
+\end{code}
+
+ src/Version.hs view
@@ -0,0 +1,7 @@+--Automatically generated
+module Version where
+
+pkg_name :: String
+pkg_name    = "HaskellDirect (ihc.exe)"
+pkg_version :: String
+pkg_version = "version 0.21"
+ src/mkNativeInfo.c view
@@ -0,0 +1,100 @@+/*
+ Using the C compiler, figure out properties of
+ basic types on a platform, outputting them
+ into a .hs file.
+ */
+#include <stdio.h>
+
+/* Basic COM types. */
+typedef char* BSTR; /* Not right, but right enough! */
+
+typedef struct tagSAFEARRAYBOUND {
+    unsigned long cElements;
+    long  lLbound;
+} SAFEARRAYBOUND;
+
+typedef struct tagSAFEARRAY {
+    unsigned short cDims;
+    unsigned short fFeatures;
+    unsigned long  cbElements;
+    unsigned long  cLocks;
+    void*          pvData;
+    SAFEARRAYBOUND rgsabound[1];
+} SAFEARRAY;
+
+#define alignment(TYPE) ((long)((char *)&((struct{char c; TYPE d;}*)0)->d - (char *) 0))
+
+#define FLOAT_SIZE  sizeof(float)
+#define FLOAT_ALIGN alignment(float)
+#define DOUBLE_SIZE sizeof(double)
+#define DOUBLE_ALIGN alignment(double)
+#define SHORT_SIZE   sizeof(short int)
+#define SHORT_ALIGN  alignment(short int)
+#define LONG_SIZE   sizeof(long int)
+#define LONG_ALIGN  alignment(long int)
+#define LONGLONG_SIZE   sizeof(long long int)
+#define LONGLONG_ALIGN  alignment(long long int)
+#define USHORT_SIZE   sizeof(unsigned short int)
+#define USHORT_ALIGN  alignment(unsigned short int)
+#define ULONG_SIZE   sizeof(unsigned long int)
+#define ULONG_ALIGN  alignment(unsigned long int)
+#define ULONGLONG_SIZE   sizeof(unsigned long long int)
+#define ULONGLONG_ALIGN  alignment(unsigned long long int)
+#define UCHAR_SIZE   sizeof(unsigned char)
+#define UCHAR_ALIGN  alignment(unsigned char)
+#define SCHAR_SIZE   sizeof(signed char)
+#define SCHAR_ALIGN  alignment(signed char)
+#define DATA_PTR_SIZE   sizeof(long *)
+#define DATA_PTR_ALIGN  alignment(long *)
+#define BSTR_SIZE   sizeof(BSTR)
+#define BSTR_ALIGN  alignment(BSTR)
+#define SAFEARRAY_SIZE   sizeof(SAFEARRAY)
+#define SAFEARRAY_ALIGN  alignment(SAFEARRAY)
+#define STRUCT_ALIGN  alignment(struct _foo {char x; char y;})
+
+void
+dump_def(char* nm, int val1, int val2)
+{
+  printf("%s_SIZE :: Int\n", nm);
+  printf("%s_SIZE = %d\n", nm,val1);
+  printf("%s_ALIGN_MODULUS :: Int\n", nm);
+  printf("%s_ALIGN_MODULUS = %d\n", nm, val2);
+}
+
+int
+main()
+{
+  printf("-- This file was created by mkNativeInfo. Do not edit by hand.\n\n");
+
+  printf("module NativeInfo where\n\n");
+
+  dump_def("fLOAT",  FLOAT_SIZE, FLOAT_ALIGN);
+  dump_def("dOUBLE", DOUBLE_SIZE, DOUBLE_ALIGN);
+
+  dump_def("sHORT", SHORT_SIZE, SHORT_ALIGN);
+
+  dump_def("lONG", LONG_SIZE, LONG_ALIGN);
+
+  dump_def("lONGLONG", LONGLONG_SIZE, LONGLONG_ALIGN);
+
+  dump_def("uSHORT", USHORT_SIZE, USHORT_ALIGN);
+
+  dump_def("uLONG", ULONG_SIZE, ULONG_ALIGN);
+
+  dump_def("uLONGLONG", ULONGLONG_SIZE, ULONGLONG_ALIGN);
+
+  dump_def("uCHAR", UCHAR_SIZE, UCHAR_ALIGN);
+
+  dump_def("sCHAR", SCHAR_SIZE, SCHAR_ALIGN);
+
+  dump_def("dATA_PTR", DATA_PTR_SIZE, DATA_PTR_ALIGN);
+
+  dump_def("bSTR", BSTR_SIZE, BSTR_ALIGN);
+
+  dump_def("sAFEARRAY", SAFEARRAY_SIZE, SAFEARRAY_ALIGN);
+
+  printf("sTRUCT_ALIGN_MODULUS ::Int\n");
+  printf("sTRUCT_ALIGN_MODULUS = %d\n", STRUCT_ALIGN);
+
+  return(0);
+}