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

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

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.

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)

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)

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)

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))