% % (c) The Foo Project, University of Glasgow, 1998 % % @(#) $Docid: Feb. 9th 2003 15:53 Sigbjorn Finne $ % @(#) $Contactid: sof@galois.com $ % The generated code makes use of a number of library functions. This module abstracts away from their names and locations. \begin{code} 
module LibUtils
        (
	  hdirectLib
	, bitsLib
	, comLib
	, comServLib
	, prelude
	, maybe_module
	, autoLib
	, ioExts
	, intLib
	, wordLib
--	, addrLib
	, foreignLib
	, arrayLib
	, jniLib
	, wStringLib
	, safeArrayLib
	, ptrLib
	, foreignPtrLib
	
	, iDispatch
	, iUnknown
	, iUnknownFO
	, iID
	, cLSID
	, gUID
	, lIBID
	, mkIID
	, mkCLSID
	, mkLIBID
	, primIP
	, currency
	, variantClass
	, variantType
	, groundInterface

	, vARIANT
	, sAFEARRAY

	, derefPtr
	, indexPtr
	, interfacePtrToAddr
	, intToAddr
	, mkWString
	, lengthWString
	
	, castPtrName
	, castFPtrName
	, withForeignPtrName

	, checkHR
	, check2HR
	, invokeAndCheck
	, returnHR
	, invokeIt
	, primInvokeIt
	
	, getIfaceState
	, createComVTable
	, createDispVTable
	, comVTableTy
	, createComInst
	, mkComInterface
	, mkDispInterface
	, mkDualInterface
	, comInterfaceTy
	
	, componentInfo
	, mkComponentInfo
	, hasTypeLib
	
	, mkForeignObj

	, trivialFree
	, allocOutPointer
	, allocBytes
	, allocWords

	, list
	, blist
	, bstring
	, ref
	, unique
--	, ptr
	, fptr
	, iptr
	, wstring
	, wstring2

	, enum32
	, enum16

	, stringName
	, bool
	, integer
	, bstr
	, safearray
	, ptrName
	, funPtrName
	, foreignPtrName
	
	, free
	, freeRef
	, doThenFree
	, nullPtr
	, nullFO
	, nullFinaliser
	, nullIPointer
	, prelError
	, raiseIOException
	, prelUserError
	, prelReturn
	, bindName
	, bind_Name
	
        , xorName
        , orName
        , andName
        , shiftLName
        , shiftRName
	, bitsClass
	, complementName
	, shiftName
	, rotateName
	, bitSizeName
	, isSignedName

        , addName
        , subName
        , divName
        , modName
        , mulName
        , logAndName
        , logOrName
        , gtName
        , geName
        , eqName
        , leName
        , ltName
        , neName
        , negateName
        , notName

	, marshStruct
	, unmarshStruct
	, marshUnion
	, unmarshUnion
	
	, dollarName
	, inArgName
	, inIUnknownArgName
	, outArgName
	, inoutArgName
	, retValName
	, applyName
	, mkDispMethod
	
	, enumClass
	, eqClass
	, showClass
	, numClass

	, fromEnumName
	, toEnumName
	
	, enumToInt
	, enumToFlag
	, unboxInt
	, flagToIntTag
	, tagToEnum
	, toIntFlag
	, pow2Series
	, orListName
	, orFlagsName
	, orFlagName
	, flagsClass
	
	, inVariantName
	, resVariantName
	, defaultVariantName
	, vtEltTypeName

	, fromMaybeName
	, maybeName
	, justName
	, nothingName
	, mapName
	, mapListName
	, concatName
	, concatMapName
	, intersectName
	, mapMaybeName
	, sumName
	, fromIntegralName
	, lengthName
	
	, true
	, false
	
	, uPerformIO

	, marshallPrefix
	, marshallRefPrefix
	, unmarshallPrefix
	, unmarshallRefPrefix
	, sizeofPrefix
	, sizeOfName
	, outPrefix
	, allocPrefix
	, freePrefix
	, copyPrefix
	
	, marshallMaybe
	, writeMaybe
	, readMaybe

        , mkPrimitiveName
	, mkWrapperName
        , mkPrimExportName
	, mkVtblOffsetName
	, mkCLSIDName
	, mkLIBIDName
	
	, defaultCConv
	
	, invokeMethod
	, invokeStaticMethod
	, invokeInterfaceMethod
	, getField
	, getStaticField
	, setField
	, setStaticField
	, inArg
	, jvalueClass
	, jObject
	, jArray
	, jniEnv
	, fPointer

	, newObj
	, className
	, makeClassName
	, mkClassName
	, newFPointer
	
	, orbLib
	, cObject
	
       ) where

import BasicTypes
import Opts ( optHaskellToC, optH1_4, 
	      optCorba
	    )
\end{code} Where it's at - the different modules we may end up generating imports from: \begin{code} 
hdirectLib, bitsLib, comLib, comServLib, listLib, ptrLib, foreignPtrLib :: Maybe String
hdirectLib = Just "HDirect"
bitsLib = Just "Bits"
comLib  = Just "Com"
comServLib  = Just "ComServ"
listLib = Just "List"
ptrLib  = Just "Foreign.Ptr"
foreignPtrLib = Just "Foreign.ForeignPtr"

comDll, prelude, prelGHC, maybe_module, autoLib, ioExts :: Maybe String
comDll  = Just "ComDll"
prelude = Just "Prelude"
prelGHC = Just "PrelGHC"
maybe_module = Just "Maybe"
autoLib = Just "Automation"
ioExts  = Just "System.IO"

intLib, wordLib, foreignLib, arrayLib :: Maybe String
intLib  = Just "Int"
wordLib = Just "Word"
--addrLib = Just "Addr"
foreignLib = Just "Foreign"
arrayLib   = Just "Array"

stdDispatchLib, wStringLib, jniLib, orbLib, safeArrayLib :: Maybe String
stdDispatchLib = Just "StdDispatch"
wStringLib = Just "WideString"
safeArrayLib = Just "SafeArray"

jniLib = Just "JNI"
orbLib = Just "Corba"
\end{code} Some standard COM types/functions : \begin{code} 
iDispatch, iUnknown, iUnknownFO, primIP, iID, cLSID, gUID, lIBID, mkIID, mkCLSID, mkLIBID :: QualName
iDispatch  = mkQualName autoLib "IDispatch"
iUnknown   = mkQualName comLib "IUnknown"
iUnknownFO = mkQualName comLib "IUnknownFO"
primIP     = mkQualName comLib "PrimIP"
iID        = mkQualName comLib "IID"
cLSID      = mkQualName comLib "CLSID"
gUID       = mkQualName comLib "GUID"
lIBID      = mkQualName comLib "LIBID"
mkIID      = mkQualName comLib "mkIID"
mkCLSID    = mkQualName comLib "mkCLSID"
mkLIBID    = mkQualName comLib "mkLIBID"

mkForeignObj, nullIPointer, groundInterface :: QualName

-- since ghc-4.08.1's Foreign.makeForeignObj doesn't quite work,
-- we rely on the FO creator in the HDirect support libs instead.
--mkForeignObj = mkQualName foreignLib "makeForeignObj"
mkForeignObj = mkQualName (Just "Pointer") "makeFO"

nullIPointer = mkQualName comLib "interfaceNULL"

groundInterface = mkQualName Nothing "()"

currency, vARIANT, sAFEARRAY :: QualName
currency     = mkQualName autoLib "Currency"
vARIANT      = mkQualName autoLib "VARIANT"
sAFEARRAY    = mkQualName safeArrayLib "SAFEARRAY"

dollarName :: QualName
dollarName   = mkQualName prelude "$"

derefPtr, interfacePtrToAddr, intToAddr, indexPtr :: QualName
derefPtr      = mkQualName hdirectLib "derefPtr"
interfacePtrToAddr = mkQualName comLib "interfacePtrToAddr"
intToAddr      = mkQualName hdirectLib "intToAddr"
indexPtr       = mkQualName hdirectLib "indexPtr"

castPtrName, castFPtrName, withForeignPtrName :: QualName
castPtrName    = mkQualName ptrLib     "castPtr"
castFPtrName   = mkQualName foreignPtrLib "castForeignPtr"
withForeignPtrName = mkQualName foreignPtrLib "withForeignPtr"

checkHR, check2HR, invokeAndCheck, returnHR, invokeIt, primInvokeIt :: QualName
checkHR	       = mkQualName comLib "checkHR"
check2HR       = mkQualName comLib "check2HR"
invokeAndCheck = mkQualName comLib "invokeAndCheck"
returnHR       = mkQualName comLib "returnHR"
invokeIt       = mkQualName comLib "invokeIt"
primInvokeIt   = mkQualName hdirectLib "primInvokeIt"

variantClass, variantType, inVariantName, resVariantName, defaultVariantName, vtEltTypeName :: QualName
variantClass   = mkQualName autoLib "Variant"
variantType    = mkQualName autoLib "VARIANT"
inVariantName  = mkQualName autoLib "inVariant"
resVariantName = mkQualName autoLib "resVariant"
defaultVariantName = mkQualName autoLib "defaultVariant"
vtEltTypeName  = mkQualName autoLib "vtEltType"

getIfaceState, createComVTable, comVTableTy, createComInst :: QualName
getIfaceState    = mkQualName comServLib "getObjState"
createComVTable  = mkQualName comServLib "createComVTable"
comVTableTy      = mkQualName comServLib "ComVTable"
createComInst    = mkQualName comServLib "createComInstance"

mkComInterface, mkDispInterface, mkDualInterface, comInterfaceTy :: QualName
mkComInterface   = mkQualName comServLib "mkIface"
mkDispInterface  = mkQualName comServLib "mkDispIface"
mkDualInterface  = mkQualName comServLib "mkDualIface"
comInterfaceTy   = mkQualName comServLib "ComInterface"

componentInfo, mkComponentInfo, hasTypeLib :: QualName
componentInfo    = mkQualName comDll "ComponentInfo"
mkComponentInfo  = mkQualName comDll "mkComponentInfo"
hasTypeLib       = mkQualName comDll "hasTypeLib"

inArgName, inIUnknownArgName, outArgName, inoutArgName, retValName, applyName :: QualName
inArgName         = mkQualName stdDispatchLib "inArg"
inIUnknownArgName = mkQualName stdDispatchLib "inIUnknownArg"
outArgName        = mkQualName stdDispatchLib "outArg"
inoutArgName      = mkQualName stdDispatchLib "inoutArg"
retValName        = mkQualName stdDispatchLib "retVal"
applyName         = mkQualName stdDispatchLib "apply_"

createDispVTable, mkDispMethod :: QualName
createDispVTable = mkQualName stdDispatchLib "createStdDispatchVTBL2"
mkDispMethod     = mkQualName stdDispatchLib "mkDispMethod"

trivialFree, free, freeRef, doThenFree :: QualName
trivialFree   = mkQualName hdirectLib "trivialFree"
free          = mkQualName hdirectLib "free"
freeRef	      = mkQualName hdirectLib "freeref"
doThenFree    = mkQualName hdirectLib "doThenFree"

nullPtr, nullFO, nullFinaliser, prelError, prelFail, prelIOError :: QualName
nullPtr       = mkQualName ptrLib     "nullPtr"
nullFO        = mkQualName hdirectLib "nullFO"
nullFinaliser = mkQualName hdirectLib "nullFinaliser"
prelError     = mkQualName prelude    "error"
prelFail      = mkQualName prelude    "fail"
prelIOError   = mkQualName prelude    "ioError"

prelUserError, prelReturn, bindName, bind_Name :: QualName
prelUserError = mkQualName prelude    "userError"
prelReturn    = mkQualName prelude    "return"
bindName      = mkQualName prelude    ">>="
bind_Name     = mkQualName prelude    ">>"

xorName, orName, andName, shiftLName, shiftRName :: QualName
xorName       = mkQualName bitsLib    "xor"
orName        = mkQualName bitsLib    ".|."
andName       = mkQualName bitsLib    ".&."
shiftLName    = mkQualName bitsLib    "shiftL"
shiftRName    = mkQualName bitsLib    "shiftR"

complementName, shiftName, rotateName, bitSizeName, isSignedName :: QualName
complementName = mkQualName bitsLib    "complement"
shiftName      = mkQualName bitsLib    "shift"
rotateName     = mkQualName bitsLib    "rotate"
bitSizeName    = mkQualName bitsLib    "bitSize"
isSignedName   = mkQualName bitsLib    "isSigned"

bitsClass :: QualName
bitsClass     = mkQualName bitsLib    "Bits"

addName, subName, divName, modName, mulName :: QualName
addName       = mkQualName prelude    "+"
subName       = mkQualName prelude    "-"
divName       = mkQualName prelude    "div"
modName       = mkQualName prelude    "mod"
mulName       = mkQualName prelude    "*"

logAndName, logOrName :: QualName
logAndName    = mkQualName prelude    "&&"
logOrName     = mkQualName prelude    "||"
gtName, geName, eqName, leName, ltName, neName :: QualName
gtName        = mkQualName prelude    ">"
geName        = mkQualName prelude    ">="
eqName        = mkQualName prelude    "=="
leName        = mkQualName prelude    "<="
ltName        = mkQualName prelude    "<"
neName        = mkQualName prelude    "/="

negateName, notName :: QualName
negateName    = mkQualName prelude    "negate"
notName       = mkQualName prelude    "not"

marshStruct, unmarshStruct, marshUnion, unmarshUnion :: QualName
marshStruct   = mkQualName hdirectLib "marshallStruct"
unmarshStruct = mkQualName hdirectLib "unmarshallStruct"
marshUnion    = mkQualName hdirectLib "marshallUnion"
unmarshUnion  = mkQualName hdirectLib "unmarshallUnion"

marshallMaybe, writeMaybe, readMaybe :: QualName
marshallMaybe = mkQualName hdirectLib "marshallMaybe"
writeMaybe    = mkQualName hdirectLib "writeMaybe"
readMaybe     = mkQualName hdirectLib "readMaybe"

eqClass, numClass, showClass, enumClass, fromEnumName, toEnumName :: QualName
eqClass       = mkQualName prelude "Eq"
showClass     = mkQualName prelude "Show"
numClass      = mkQualName prelude "Num"
enumClass     = mkQualName prelude "Enum"
fromEnumName  = mkQualName prelude "fromEnum"
toEnumName    = mkQualName prelude "toEnum"

enumToInt, enumToFlag, flagToIntTag, pow2Series :: QualName
enumToInt     = mkQualName hdirectLib "enumToInt"
enumToFlag    = mkQualName hdirectLib "enumToFlag"
flagToIntTag  = mkQualName hdirectLib "flagToIntTag"
pow2Series    = mkQualName hdirectLib "pow2Series"

orListName :: QualName
orListName    = mkQualName hdirectLib "orList"

orFlagsName :: QualName
orFlagsName    = mkQualName hdirectLib "orFlags"

flagsClass :: QualName
flagsClass = mkQualName hdirectLib "Flags"

orFlagName :: QualName
orFlagName = mkQualName hdirectLib ".+."

unboxInt, tagToEnum, toIntFlag :: QualName
unboxInt      = mkQualName hdirectLib "unboxInt"
tagToEnum     = mkQualName prelGHC    "tagToEnum#"
toIntFlag     = mkQualName hdirectLib "toIntFlag"

fromMaybeName, maybeName :: QualName
fromMaybeName = mkQualName maybe_module "fromMaybe"
maybeName     = mkQualName prelude "Maybe"
justName, nothingName :: QualName
justName      = mkQualName prelude "Just"
nothingName   = mkQualName prelude "Nothing"

lengthName :: QualName
lengthName = mkQualName prelude "length"

mapName :: QualName
mapName
 | optH1_4    = mkQualName prelude "map"
 | otherwise  = mkQualName prelude "fmap"

mapListName :: QualName
mapListName   = mkQualName prelude "map"

concatName :: QualName
concatName   = mkQualName prelude "concat"

concatMapName :: QualName
concatMapName   = mkQualName listLib "concatMap"

intersectName :: QualName
intersectName   = mkQualName listLib "intersect"

mapMaybeName :: QualName
mapMaybeName   = mkQualName maybe_module "mapMaybe"

sumName :: QualName
sumName   = mkQualName prelude "sum"

fromIntegralName :: QualName
fromIntegralName = mkQualName prelude "fromIntegral"

true, false :: QualName
true	      = mkQualName prelude "True"
false	      = mkQualName prelude "False"

uPerformIO :: QualName
uPerformIO    = mkQualName ioExts  "unsafePerformIO"

mkWString :: QualName
mkWString     = mkQualName wStringLib "mkWideString"

lengthWString :: QualName
lengthWString     = mkQualName wStringLib "lengthWideString"

allocOutPointer, allocBytes, allocWords :: QualName
allocOutPointer = mkQualName hdirectLib "allocOutPtr"
allocBytes	= mkQualName hdirectLib "allocBytes"
allocWords	= mkQualName hdirectLib "allocWords"
\end{code} \begin{code} 
list, blist, bstring, fptr, iptr :: String
list    = "list"
blist   = "blist"
bstring = "BString"
--ptr     = "ptr"
fptr    = "fptr"
iptr    = "iptr"

ref, unique :: String
ref     = "ref"
unique  = "unique"

stringName , wstring, wstring2 :: String
stringName = "String"
wstring    = "WideString"
wstring2   = "WideString2"

ptrName, funPtrName, foreignPtrName :: String
ptrName  = "Ptr"
funPtrName = "FunPtr"
foreignPtrName = "ForeignPtr"

bool, integer, bstr, safearray :: String
bool    = "Bool"
integer = "Integer"
bstr    = "BSTR"
safearray = "SafeArray"

enum32, enum16 :: String
enum32  = "Enum32"
enum16  = "Enum16"
\end{code} The Haskell names for the different functions that we generate during the translation from IDL to Haskell are formed by adding a prefix to the (Haskell) type of the value we're marshalling to/from: \begin{code} 
outPrefix, unmarshallPrefix, marshallPrefix :: String
marshallPrefix      = "marshall"
outPrefix           = "o_"
unmarshallPrefix    = "unmarshall"

marshallRefPrefix, unmarshallRefPrefix, allocPrefix, sizeofPrefix :: String
marshallRefPrefix   = "write"
unmarshallRefPrefix = "read"
allocPrefix         = "alloc"
sizeofPrefix        = "sizeof"

freePrefix, copyPrefix :: String
freePrefix          = "free"
copyPrefix          = "copy"

-- given the name of a method/function, produce the
-- name of the primitive Haskell function that represent it.
mkPrimitiveName :: String -> String
mkPrimitiveName nm = "prim_"++nm

-- wrappers are Haskell functions that convert between
-- the expected signature of an external function type or method
-- and the Haskell implementation - i.e., arguments are marshalled
-- prior to calling the Haskell function, followed by unmarshalling
-- it's result.
mkWrapperName :: String -> String
mkWrapperName nm = "wrap_"++nm

mkPrimExportName :: String -> String
mkPrimExportName nm = "export_" ++ nm

mkVtblOffsetName :: String -> String -> String
mkVtblOffsetName iface meth = "off_" ++ iface ++ '_':meth


mkCLSIDName :: String -> String
mkCLSIDName cls_nm = "clsid" ++ cls_nm

mkLIBIDName :: String -> String
mkLIBIDName cls_nm = "libid" ++ cls_nm

mkClassName :: String -> String
mkClassName nm = nm ++ "ClassName"
\end{code} \begin{code} 
invokeMethod :: QualName
invokeMethod          = mkQualName jniLib "callMethodPrim"

invokeStaticMethod :: QualName
invokeStaticMethod    = mkQualName jniLib "invokeStaticMethod"

invokeInterfaceMethod :: QualName
invokeInterfaceMethod = mkQualName jniLib "callMethodPrim"

getField :: QualName
getField              = mkQualName jniLib "getFieldPrim"

getStaticField :: QualName
getStaticField        = mkQualName jniLib "get_StaticField"

setField :: QualName
setField              = mkQualName jniLib "setFieldPrim"

setStaticField :: QualName
setStaticField        = mkQualName jniLib "set_StaticField"

inArg, jvalueClass, jObject, jArray, jniEnv :: QualName
inArg         = mkQualName jniLib "inVal"
jvalueClass   = mkQualName jniLib "JValue"
jObject       = setOrigQName "java.lang.Object" (mkQualName jniLib "JObject")
jArray        = mkQualName jniLib "JArray"
jniEnv        = mkQualName jniLib "JNIEnv"

fPointer, newObj, className, makeClassName, newFPointer :: QualName
fPointer      = mkQualName jniLib "FunctionPtr"
newObj        = mkQualName jniLib "new"
className     = mkQualName jniLib "ClassName"
makeClassName = mkQualName jniLib "mkClassName"
newFPointer   = mkQualName jniLib "new_FunctionPtr"
\end{code} \begin{code} 
cObject :: QualName
cObject  = mkQualName orbLib "Object"
\end{code} The method calling convention used if none specified. \begin{code} 
defaultCConv :: CallConv
defaultCConv 
 | optHaskellToC || optCorba = Cdecl
 | otherwise     = Stdcall
\end{code} \begin{code} 
raiseIOException :: QualName
raiseIOException 
  | optH1_4   = prelFail
  | otherwise = prelIOError
\end{code} FFI names \begin{code} 
sizeOfName :: String
sizeOfName = "sizeOf"
\end{code}