%
% (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
, getHsImports
, 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
, isHRESULT
, 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
, 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
\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
inSeparateHaskellModule :: Decl -> Bool
inSeparateHaskellModule Module{} = True
inSeparateHaskellModule Library{} = True
inSeparateHaskellModule DispInterface{} = optOneModulePerInterface
inSeparateHaskellModule Interface{} = optOneModulePerInterface
inSeparateHaskellModule CoClass{} = optOneModulePerInterface
inSeparateHaskellModule _ = False
localiseTypes :: [Decl] -> [Decl]
localiseTypes ds
| not optOneModulePerInterface = ds
| otherwise =
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
[Decl]
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
_ -> []
uniqueEnv :: Env String
String
uniqueEnv = mapMaybeEnv isOfInterest useEnv
where
isOfInterest _ ls =
case nub ls of
[x] | x `notElem` allTD_Names -> Just x
_ -> Nothing
isOfInterest _ _ = Nothing
useEnv :: Env String
[String]
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)
[]
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)
findFieldTy (f : xs) nm
| nm == idName (fieldId f) = fieldType f
| otherwise = findFieldTy xs nm
findFieldOrigTy :: [Field] -> Name -> Type
findFieldOrigTy [] nm = error ("findFieldOrigTy: " ++ nm)
findFieldOrigTy (f : xs) nm
| nm == idName (fieldId f) = fieldOrigType f
| otherwise = findFieldOrigTy xs nm
findParam :: [Param] -> Name -> Param
findParam [] nm = error ("findParam: " ++ nm)
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 :: 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
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
addrTy :: Type
addrTy = Pointer Ptr True Void
charTy :: Type
charTy = Char False
wCharTy :: Type
wCharTy = WChar
boolTy :: Type
boolTy = Bool
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
int64Ty :: Type
int64Ty = Integer LongLong True
word64Ty :: Type
word64Ty = Integer LongLong False
word32Ty :: Type
word32Ty = Integer Long False
word16Ty :: Type
word16Ty = Integer Short False
int16Ty :: Type
int16Ty = Integer Short True
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
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
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"
, "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
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
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
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
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
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
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))
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))
_ -> 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
Just (Left x) -> Lit (iLit (toInteger x))
Just (Right e) -> e
Lit l -> Lit l
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
| DepVal (Maybe Name)
Expr
deriving (Show)
data Dependent = Dep DepReason [DepVal]
deriving ( Show )
\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)
toDepVal (ParamVar v) = DepVal (Just v) (Var v)
toDepVal (ParamExpr (Var v)) = DepVal (Just v) (Var v)
toDepVal ParamVoid = DepNone
toDepVal (ParamExpr e) =
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
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
genLowerBound DepNone = DepVal Nothing (Lit (iLit (0::Int)))
genLowerBound d = d
genLength DepNone d = d
genLength d _ = d
genEnd DepNone (DepVal fv l) (DepVal _ f)
= DepVal fv (minusOne (add l f))
genEnd d _ _ = d
genUpperBound DepNone DepNone
= DepNone
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 _ [] = []
mapHead f (x:_) = f x
fillInDims ls = go dimensions ls
where
go 0 _ = []
go n (x:xs) = x:go (n1) xs
go n [] = DepNone:go (n1) []
\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
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"
toHask (x:xs) | not (isAlpha x) = toHask xs
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"
toHask (x:xs) | not (isAlpha x) = toHask xs
toHask ls@(x:xs)
| isLower x = toUpper x : map (subst '$' '_') xs
| otherwise = map (subst '$' '_') ls
subst x y ch | x == ch = y
| otherwise = ch
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
String
toCType ty =
case ty of
Char signed
| signed -> Left "signed char"
| otherwise -> Left "unsigned char"
WChar -> Left "wchar_t"
Bool -> Left "int"
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)
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
-> 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 =
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
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
ds_depped = map mkDeclDep ds
ds_groups = stronglyConnComp ds_depped
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
_ -> []
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
\end{code}
\begin{code}
sizeofType :: Type -> Int
sizeofType t = fst (sizeAndAlignModulus Nothing t)
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)
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)
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, _) = sizeAndAlignModulus mb_pack tty
uni_sz = maximum sw_sizes
uni_align = realModulus mb_pack (maximum sw_aligns)
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)
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)
Name "VARIANT" _ _ _ _ _ -> (16, 8)
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
, Int
)
-> Field
-> ( (Int,Int)
, Int
)
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 :: Int -> Int -> Int
align off al
| off `mod` al == 0 = off
| 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
\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}