src/CoreUtils.lhs

% % (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 @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.) @is@ is the [in] parameters (preserved left-to-right ordering of original parameter list.) @os@ is the [out] params. @ios@ is the [in,out] params. @rs@ is the parameters that should be returned as results from the Haskell programmer. \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}