%
% (c) The Foo Project, University of Glasgow, 1998
%
% @(#) $Docid: Feb. 9th 2003 15:53 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
The generated code makes use of a number of library functions. This
module abstracts away from their names and locations.
\begin{code}
module LibUtils
(
hdirectLib
, bitsLib
, comLib
, comServLib
, prelude
, maybe_module
, autoLib
, ioExts
, intLib
, wordLib
, foreignLib
, arrayLib
, jniLib
, wStringLib
, safeArrayLib
, ptrLib
, foreignPtrLib
, iDispatch
, iUnknown
, iUnknownFO
, iID
, cLSID
, gUID
, lIBID
, mkIID
, mkCLSID
, mkLIBID
, primIP
, currency
, variantClass
, variantType
, groundInterface
, vARIANT
, sAFEARRAY
, derefPtr
, indexPtr
, interfacePtrToAddr
, intToAddr
, mkWString
, lengthWString
, castPtrName
, castFPtrName
, withForeignPtrName
, checkHR
, check2HR
, invokeAndCheck
, returnHR
, invokeIt
, primInvokeIt
, getIfaceState
, createComVTable
, createDispVTable
, comVTableTy
, createComInst
, mkComInterface
, mkDispInterface
, mkDualInterface
, comInterfaceTy
, componentInfo
, mkComponentInfo
, hasTypeLib
, mkForeignObj
, trivialFree
, allocOutPointer
, allocBytes
, allocWords
, list
, blist
, bstring
, ref
, unique
, fptr
, iptr
, wstring
, wstring2
, enum32
, enum16
, stringName
, bool
, integer
, bstr
, safearray
, ptrName
, funPtrName
, foreignPtrName
, free
, freeRef
, doThenFree
, nullPtr
, nullFO
, nullFinaliser
, nullIPointer
, prelError
, raiseIOException
, prelUserError
, prelReturn
, bindName
, bind_Name
, xorName
, orName
, andName
, shiftLName
, shiftRName
, bitsClass
, complementName
, shiftName
, rotateName
, bitSizeName
, isSignedName
, addName
, subName
, divName
, modName
, mulName
, logAndName
, logOrName
, gtName
, geName
, eqName
, leName
, ltName
, neName
, negateName
, notName
, marshStruct
, unmarshStruct
, marshUnion
, unmarshUnion
, dollarName
, inArgName
, inIUnknownArgName
, outArgName
, inoutArgName
, retValName
, applyName
, mkDispMethod
, enumClass
, eqClass
, showClass
, numClass
, fromEnumName
, toEnumName
, enumToInt
, enumToFlag
, unboxInt
, flagToIntTag
, tagToEnum
, toIntFlag
, pow2Series
, orListName
, orFlagsName
, orFlagName
, flagsClass
, inVariantName
, resVariantName
, defaultVariantName
, vtEltTypeName
, fromMaybeName
, maybeName
, justName
, nothingName
, mapName
, mapListName
, concatName
, concatMapName
, intersectName
, mapMaybeName
, sumName
, fromIntegralName
, lengthName
, true
, false
, uPerformIO
, marshallPrefix
, marshallRefPrefix
, unmarshallPrefix
, unmarshallRefPrefix
, sizeofPrefix
, sizeOfName
, outPrefix
, allocPrefix
, freePrefix
, copyPrefix
, marshallMaybe
, writeMaybe
, readMaybe
, mkPrimitiveName
, mkWrapperName
, mkPrimExportName
, mkVtblOffsetName
, mkCLSIDName
, mkLIBIDName
, defaultCConv
, invokeMethod
, invokeStaticMethod
, invokeInterfaceMethod
, getField
, getStaticField
, setField
, setStaticField
, inArg
, jvalueClass
, jObject
, jArray
, jniEnv
, fPointer
, newObj
, className
, makeClassName
, mkClassName
, newFPointer
, orbLib
, cObject
) where
import BasicTypes
import Opts ( optHaskellToC, optH1_4,
optCorba
)
\end{code}
Where it's at - the different modules we may end up
generating imports from:
\begin{code}
hdirectLib, bitsLib, comLib, comServLib, listLib, ptrLib, foreignPtrLib :: Maybe String
hdirectLib = Just "HDirect"
bitsLib = Just "Bits"
comLib = Just "Com"
comServLib = Just "ComServ"
listLib = Just "List"
ptrLib = Just "Foreign.Ptr"
foreignPtrLib = Just "Foreign.ForeignPtr"
comDll, prelude, prelGHC, maybe_module, autoLib, ioExts :: Maybe String
comDll = Just "ComDll"
prelude = Just "Prelude"
prelGHC = Just "PrelGHC"
maybe_module = Just "Maybe"
autoLib = Just "Automation"
ioExts = Just "System.IO"
intLib, wordLib, foreignLib, arrayLib :: Maybe String
intLib = Just "Int"
wordLib = Just "Word"
foreignLib = Just "Foreign"
arrayLib = Just "Array"
stdDispatchLib, wStringLib, jniLib, orbLib, safeArrayLib :: Maybe String
stdDispatchLib = Just "StdDispatch"
wStringLib = Just "WideString"
safeArrayLib = Just "SafeArray"
jniLib = Just "JNI"
orbLib = Just "Corba"
\end{code}
Some standard COM types/functions :
\begin{code}
iDispatch, iUnknown, iUnknownFO, primIP, iID, cLSID, gUID, lIBID, mkIID, mkCLSID, mkLIBID :: QualName
iDispatch = mkQualName autoLib "IDispatch"
iUnknown = mkQualName comLib "IUnknown"
iUnknownFO = mkQualName comLib "IUnknownFO"
primIP = mkQualName comLib "PrimIP"
iID = mkQualName comLib "IID"
cLSID = mkQualName comLib "CLSID"
gUID = mkQualName comLib "GUID"
lIBID = mkQualName comLib "LIBID"
mkIID = mkQualName comLib "mkIID"
mkCLSID = mkQualName comLib "mkCLSID"
mkLIBID = mkQualName comLib "mkLIBID"
mkForeignObj, nullIPointer, groundInterface :: QualName
mkForeignObj = mkQualName (Just "Pointer") "makeFO"
nullIPointer = mkQualName comLib "interfaceNULL"
groundInterface = mkQualName Nothing "()"
currency, vARIANT, sAFEARRAY :: QualName
currency = mkQualName autoLib "Currency"
vARIANT = mkQualName autoLib "VARIANT"
sAFEARRAY = mkQualName safeArrayLib "SAFEARRAY"
dollarName :: QualName
dollarName = mkQualName prelude "$"
derefPtr, interfacePtrToAddr, intToAddr, indexPtr :: QualName
derefPtr = mkQualName hdirectLib "derefPtr"
interfacePtrToAddr = mkQualName comLib "interfacePtrToAddr"
intToAddr = mkQualName hdirectLib "intToAddr"
indexPtr = mkQualName hdirectLib "indexPtr"
castPtrName, castFPtrName, withForeignPtrName :: QualName
castPtrName = mkQualName ptrLib "castPtr"
castFPtrName = mkQualName foreignPtrLib "castForeignPtr"
withForeignPtrName = mkQualName foreignPtrLib "withForeignPtr"
checkHR, check2HR, invokeAndCheck, returnHR, invokeIt, primInvokeIt :: QualName
checkHR = mkQualName comLib "checkHR"
check2HR = mkQualName comLib "check2HR"
invokeAndCheck = mkQualName comLib "invokeAndCheck"
returnHR = mkQualName comLib "returnHR"
invokeIt = mkQualName comLib "invokeIt"
primInvokeIt = mkQualName hdirectLib "primInvokeIt"
variantClass, variantType, inVariantName, resVariantName, defaultVariantName, vtEltTypeName :: QualName
variantClass = mkQualName autoLib "Variant"
variantType = mkQualName autoLib "VARIANT"
inVariantName = mkQualName autoLib "inVariant"
resVariantName = mkQualName autoLib "resVariant"
defaultVariantName = mkQualName autoLib "defaultVariant"
vtEltTypeName = mkQualName autoLib "vtEltType"
getIfaceState, createComVTable, comVTableTy, createComInst :: QualName
getIfaceState = mkQualName comServLib "getObjState"
createComVTable = mkQualName comServLib "createComVTable"
comVTableTy = mkQualName comServLib "ComVTable"
createComInst = mkQualName comServLib "createComInstance"
mkComInterface, mkDispInterface, mkDualInterface, comInterfaceTy :: QualName
mkComInterface = mkQualName comServLib "mkIface"
mkDispInterface = mkQualName comServLib "mkDispIface"
mkDualInterface = mkQualName comServLib "mkDualIface"
comInterfaceTy = mkQualName comServLib "ComInterface"
componentInfo, mkComponentInfo, hasTypeLib :: QualName
componentInfo = mkQualName comDll "ComponentInfo"
mkComponentInfo = mkQualName comDll "mkComponentInfo"
hasTypeLib = mkQualName comDll "hasTypeLib"
inArgName, inIUnknownArgName, outArgName, inoutArgName, retValName, applyName :: QualName
inArgName = mkQualName stdDispatchLib "inArg"
inIUnknownArgName = mkQualName stdDispatchLib "inIUnknownArg"
outArgName = mkQualName stdDispatchLib "outArg"
inoutArgName = mkQualName stdDispatchLib "inoutArg"
retValName = mkQualName stdDispatchLib "retVal"
applyName = mkQualName stdDispatchLib "apply_"
createDispVTable, mkDispMethod :: QualName
createDispVTable = mkQualName stdDispatchLib "createStdDispatchVTBL2"
mkDispMethod = mkQualName stdDispatchLib "mkDispMethod"
trivialFree, free, freeRef, doThenFree :: QualName
trivialFree = mkQualName hdirectLib "trivialFree"
free = mkQualName hdirectLib "free"
freeRef = mkQualName hdirectLib "freeref"
doThenFree = mkQualName hdirectLib "doThenFree"
nullPtr, nullFO, nullFinaliser, prelError, prelFail, prelIOError :: QualName
nullPtr = mkQualName ptrLib "nullPtr"
nullFO = mkQualName hdirectLib "nullFO"
nullFinaliser = mkQualName hdirectLib "nullFinaliser"
prelError = mkQualName prelude "error"
prelFail = mkQualName prelude "fail"
prelIOError = mkQualName prelude "ioError"
prelUserError, prelReturn, bindName, bind_Name :: QualName
prelUserError = mkQualName prelude "userError"
prelReturn = mkQualName prelude "return"
bindName = mkQualName prelude ">>="
bind_Name = mkQualName prelude ">>"
xorName, orName, andName, shiftLName, shiftRName :: QualName
xorName = mkQualName bitsLib "xor"
orName = mkQualName bitsLib ".|."
andName = mkQualName bitsLib ".&."
shiftLName = mkQualName bitsLib "shiftL"
shiftRName = mkQualName bitsLib "shiftR"
complementName, shiftName, rotateName, bitSizeName, isSignedName :: QualName
complementName = mkQualName bitsLib "complement"
shiftName = mkQualName bitsLib "shift"
rotateName = mkQualName bitsLib "rotate"
bitSizeName = mkQualName bitsLib "bitSize"
isSignedName = mkQualName bitsLib "isSigned"
bitsClass :: QualName
bitsClass = mkQualName bitsLib "Bits"
addName, subName, divName, modName, mulName :: QualName
addName = mkQualName prelude "+"
subName = mkQualName prelude "-"
divName = mkQualName prelude "div"
modName = mkQualName prelude "mod"
mulName = mkQualName prelude "*"
logAndName, logOrName :: QualName
logAndName = mkQualName prelude "&&"
logOrName = mkQualName prelude "||"
gtName, geName, eqName, leName, ltName, neName :: QualName
gtName = mkQualName prelude ">"
geName = mkQualName prelude ">="
eqName = mkQualName prelude "=="
leName = mkQualName prelude "<="
ltName = mkQualName prelude "<"
neName = mkQualName prelude "/="
negateName, notName :: QualName
negateName = mkQualName prelude "negate"
notName = mkQualName prelude "not"
marshStruct, unmarshStruct, marshUnion, unmarshUnion :: QualName
marshStruct = mkQualName hdirectLib "marshallStruct"
unmarshStruct = mkQualName hdirectLib "unmarshallStruct"
marshUnion = mkQualName hdirectLib "marshallUnion"
unmarshUnion = mkQualName hdirectLib "unmarshallUnion"
marshallMaybe, writeMaybe, readMaybe :: QualName
marshallMaybe = mkQualName hdirectLib "marshallMaybe"
writeMaybe = mkQualName hdirectLib "writeMaybe"
readMaybe = mkQualName hdirectLib "readMaybe"
eqClass, numClass, showClass, enumClass, fromEnumName, toEnumName :: QualName
eqClass = mkQualName prelude "Eq"
showClass = mkQualName prelude "Show"
numClass = mkQualName prelude "Num"
enumClass = mkQualName prelude "Enum"
fromEnumName = mkQualName prelude "fromEnum"
toEnumName = mkQualName prelude "toEnum"
enumToInt, enumToFlag, flagToIntTag, pow2Series :: QualName
enumToInt = mkQualName hdirectLib "enumToInt"
enumToFlag = mkQualName hdirectLib "enumToFlag"
flagToIntTag = mkQualName hdirectLib "flagToIntTag"
pow2Series = mkQualName hdirectLib "pow2Series"
orListName :: QualName
orListName = mkQualName hdirectLib "orList"
orFlagsName :: QualName
orFlagsName = mkQualName hdirectLib "orFlags"
flagsClass :: QualName
flagsClass = mkQualName hdirectLib "Flags"
orFlagName :: QualName
orFlagName = mkQualName hdirectLib ".+."
unboxInt, tagToEnum, toIntFlag :: QualName
unboxInt = mkQualName hdirectLib "unboxInt"
tagToEnum = mkQualName prelGHC "tagToEnum#"
toIntFlag = mkQualName hdirectLib "toIntFlag"
fromMaybeName, maybeName :: QualName
fromMaybeName = mkQualName maybe_module "fromMaybe"
maybeName = mkQualName prelude "Maybe"
justName, nothingName :: QualName
justName = mkQualName prelude "Just"
nothingName = mkQualName prelude "Nothing"
lengthName :: QualName
lengthName = mkQualName prelude "length"
mapName :: QualName
mapName
| optH1_4 = mkQualName prelude "map"
| otherwise = mkQualName prelude "fmap"
mapListName :: QualName
mapListName = mkQualName prelude "map"
concatName :: QualName
concatName = mkQualName prelude "concat"
concatMapName :: QualName
concatMapName = mkQualName listLib "concatMap"
intersectName :: QualName
intersectName = mkQualName listLib "intersect"
mapMaybeName :: QualName
mapMaybeName = mkQualName maybe_module "mapMaybe"
sumName :: QualName
sumName = mkQualName prelude "sum"
fromIntegralName :: QualName
fromIntegralName = mkQualName prelude "fromIntegral"
true, false :: QualName
true = mkQualName prelude "True"
false = mkQualName prelude "False"
uPerformIO :: QualName
uPerformIO = mkQualName ioExts "unsafePerformIO"
mkWString :: QualName
mkWString = mkQualName wStringLib "mkWideString"
lengthWString :: QualName
lengthWString = mkQualName wStringLib "lengthWideString"
allocOutPointer, allocBytes, allocWords :: QualName
allocOutPointer = mkQualName hdirectLib "allocOutPtr"
allocBytes = mkQualName hdirectLib "allocBytes"
allocWords = mkQualName hdirectLib "allocWords"
\end{code}
\begin{code}
list, blist, bstring, fptr, iptr :: String
list = "list"
blist = "blist"
bstring = "BString"
fptr = "fptr"
iptr = "iptr"
ref, unique :: String
ref = "ref"
unique = "unique"
stringName , wstring, wstring2 :: String
stringName = "String"
wstring = "WideString"
wstring2 = "WideString2"
ptrName, funPtrName, foreignPtrName :: String
ptrName = "Ptr"
funPtrName = "FunPtr"
foreignPtrName = "ForeignPtr"
bool, integer, bstr, safearray :: String
bool = "Bool"
integer = "Integer"
bstr = "BSTR"
safearray = "SafeArray"
enum32, enum16 :: String
enum32 = "Enum32"
enum16 = "Enum16"
\end{code}
The Haskell names for the different functions that we generate
during the translation from IDL to Haskell are formed by adding
a prefix to the (Haskell) type of the value we're marshalling
to/from:
\begin{code}
outPrefix, unmarshallPrefix, marshallPrefix :: String
marshallPrefix = "marshall"
outPrefix = "o_"
unmarshallPrefix = "unmarshall"
marshallRefPrefix, unmarshallRefPrefix, allocPrefix, sizeofPrefix :: String
marshallRefPrefix = "write"
unmarshallRefPrefix = "read"
allocPrefix = "alloc"
sizeofPrefix = "sizeof"
freePrefix, copyPrefix :: String
freePrefix = "free"
copyPrefix = "copy"
mkPrimitiveName :: String -> String
mkPrimitiveName nm = "prim_"++nm
mkWrapperName :: String -> String
mkWrapperName nm = "wrap_"++nm
mkPrimExportName :: String -> String
mkPrimExportName nm = "export_" ++ nm
mkVtblOffsetName :: String -> String -> String
mkVtblOffsetName iface meth = "off_" ++ iface ++ '_':meth
mkCLSIDName :: String -> String
mkCLSIDName cls_nm = "clsid" ++ cls_nm
mkLIBIDName :: String -> String
mkLIBIDName cls_nm = "libid" ++ cls_nm
mkClassName :: String -> String
mkClassName nm = nm ++ "ClassName"
\end{code}
\begin{code}
invokeMethod :: QualName
invokeMethod = mkQualName jniLib "callMethodPrim"
invokeStaticMethod :: QualName
invokeStaticMethod = mkQualName jniLib "invokeStaticMethod"
invokeInterfaceMethod :: QualName
invokeInterfaceMethod = mkQualName jniLib "callMethodPrim"
getField :: QualName
getField = mkQualName jniLib "getFieldPrim"
getStaticField :: QualName
getStaticField = mkQualName jniLib "get_StaticField"
setField :: QualName
setField = mkQualName jniLib "setFieldPrim"
setStaticField :: QualName
setStaticField = mkQualName jniLib "set_StaticField"
inArg, jvalueClass, jObject, jArray, jniEnv :: QualName
inArg = mkQualName jniLib "inVal"
jvalueClass = mkQualName jniLib "JValue"
jObject = setOrigQName "java.lang.Object" (mkQualName jniLib "JObject")
jArray = mkQualName jniLib "JArray"
jniEnv = mkQualName jniLib "JNIEnv"
fPointer, newObj, className, makeClassName, newFPointer :: QualName
fPointer = mkQualName jniLib "FunctionPtr"
newObj = mkQualName jniLib "new"
className = mkQualName jniLib "ClassName"
makeClassName = mkQualName jniLib "mkClassName"
newFPointer = mkQualName jniLib "new_FunctionPtr"
\end{code}
\begin{code}
cObject :: QualName
cObject = mkQualName orbLib "Object"
\end{code}
The method calling convention used if none specified.
\begin{code}
defaultCConv :: CallConv
defaultCConv
| optHaskellToC || optCorba = Cdecl
| otherwise = Stdcall
\end{code}
\begin{code}
raiseIOException :: QualName
raiseIOException
| optH1_4 = prelFail
| otherwise = prelIOError
\end{code}
FFI names
\begin{code}
sizeOfName :: String
sizeOfName = "sizeOf"
\end{code}