hdirect-0.21.0: src/MarshallCore.lhs
%
% (c) The Foo Project, University of Glasgow, 1999
%
% @(#) $Docid: Dec. 9th 2003 09:07 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
Higher-level marshalling code - working over Core IDL
constructs. (That's the Official Line - the Real Reason
for this module is that it avoids creating a mutual
dependency between MarshallType and MarshallDep.)
\begin{code}
module MarshallCore
(
toHaskellMethodTy
, toHaskellTy
, paramToHaskellType
, mkHStructDef
, mkHEnumDef
, mkHUnionDef
, mkCUnionDef
, toHaskellBaseTy
, toBaseTy
, toHaskellBaseMethodTy
, mkMarshaller
, autoTypeToHaskellTy
, autoTypeToQName
, mbAutoTypeToHaskellTy
, constrainIIDParams
) where
import qualified AbstractH as Haskell ( Type, ConDecl, Context )
import AbsHUtils
import CoreIDL
import CoreUtils
import MarshallUtils
import BasicTypes
import Attribute
import Literal
import LibUtils
import PpCore
import Utils ( notNull, trace )
import Opts
import TypeInfo ( TypeInfo(..) )
import Maybe
import List ( nub )
\end{code}
Converting a interface method signature into its corresponding
Haskell type. This means taking into consideration the presence
of [out] parameters plus dependent arguments etc.
\begin{code}
toHaskellMethodTy :: Bool
-> Bool
-> Bool
-> Maybe Haskell.Type
-> [Param]
-> Result
-> (Haskell.Type, Maybe Haskell.Context)
toHaskellMethodTy isPure isServer isAuto mb_iface_ty params result
= case generaliseTys (mb_io_res_ty: the_param_tys) of
((r:ps), mb_c) -> (funTys ps r, mb_c)
_ -> error "MarshallCore.toHaskellMethodTy: unexpected result"
where
mb_io_res_ty
| isPure = the_res_ty
| otherwise = io the_res_ty
(pars, _, _, _,res) = binParams params
(real_params, par_deps) = findParamDependents False pars
(_, res_deps) = findParamDependents False res
the_param_tys =
case mb_iface_ty of
Nothing -> param_tys
Just x -> param_tys ++ [x]
(param_tys, res_tys) =
constrainIIDParams (paramToHaskellType par_deps isServer isAuto False)
(paramToHaskellType res_deps isServer isAuto True)
real_params
res_params
res_params = removeDependees res_deps res
the_res_ty =
tuple (
case (resultOrigType result) of
t | isHRESULTTy t && not optKeepHRESULT -> res_tys
| not (isVoidTy (removeNames t)) -> (res_tys ++ [toHaskellTy False (resultOrigType result)])
| otherwise -> res_tys)
constrainIIDParams :: (Param -> Haskell.Type)
-> (Param -> Haskell.Type)
-> [Param]
-> [Param]
-> ([Haskell.Type], [Haskell.Type])
constrainIIDParams paramToType resultToType params res
| optUseIIDIs = (param_tys, res_tys)
| otherwise = (param_tys_vanilla, res_tys_vanilla)
where
toIIDTyVar p ty =
case lookup (idName (paramId p)) iidIs_vars of
Just x -> replaceTyVar (mkTyCon iUnknown [uniqueTyVar ('i':show x)]) ty
_ -> toIIDTyVarRes p ty
toIIDTyVarRes p ty =
case findAttribute "iid_is" (idAttributes (paramId p)) of
Just (Attribute _ [ParamVar v]) ->
case lookup v iidIs_vars of
Just x -> replaceTyVar (uniqueTyVar ('i':show x)) ty
_ -> ty
_ -> ty
iidIs_vars = zip (nub (catMaybes (map isIIDDep res)))
[(0::Int)..]
where
isIIDDep p =
case findAttribute "iid_is" (idAttributes (paramId p)) of
Just (Attribute _ [ParamVar v]) -> Just v
_ -> Nothing
param_tys = zipWith toIIDTyVar params param_tys_vanilla
res_tys = zipWith toIIDTyVarRes res res_tys_vanilla
param_tys_vanilla = map paramToType params
res_tys_vanilla = map resultToType res
\end{code}
@toHaskellTy@ takes care of implementing the T[] translation scheme. It differs
from @toHaskellBaseTy@ in that we're mapping to the user-level representation
of the IDL type in Haskell, not the type of its marshalled/packed representation.
\begin{code}
toHaskellTy :: Bool -> Type -> Haskell.Type
toHaskellTy isGround ty =
case ty of
Integer sz s -> mkIntTy sz s
Float sz -> mkFloatTy sz
Char signed
| optJNI -> tyWord16
| otherwise -> mkCharTy signed
WChar -> tyWChar
Bool -> tyBool
Void -> tyUnit
Octet -> tyWord8
Any -> tyAddr
Object -> tyAddr
StablePtr -> tyStable
FunTy _ res ps ->
case (toHaskellMethodTy False isGround False Nothing ps res') of
(t, Nothing) -> t
(t, Just c) -> ctxtTyApp c t
where
res' = res{ resultType = removePtr (resultType res)
, resultOrigType = removePtr (resultOrigType res)
}
String _ isUnique _ -> (if isUnique then tyMaybe else id) tyString
WString isUnique _ -> (if isUnique then tyMaybe else id) tyWString
Sequence t _ _ -> tyList (toHaskellTy isGround t)
Fixed{} -> error "not implemented yet."
Name _ _ _ _ (Just o@Iface{}) _ -> toHaskellTy isGround o
Name _ _ _ _ _ (Just ti) ->
case mkTyConst (haskell_type ti) of
t | optCom && isTyVar t ->
if isGround then
mkTyConst vARIANT
else
ctxtTyApp (ctxtClass variantClass [t]) t
| otherwise -> t
Name nm _ md _ _ _ -> tyQConst (fmap mkHaskellTyConName md) (mkHaskellTyConName nm)
SafeArray t
| isGround -> mkTyConst sAFEARRAY
| otherwise -> tyQCon autoLib "SafeArray" [toHaskellTy isGround t]
Array Void _ -> tyList (toHaskellTy isGround (Pointer Ptr True Void))
Array t _
| optJNI -> mkTyCon jArray [toHaskellTy isGround t]
| otherwise -> tyList (toHaskellTy isGround t)
Pointer Unique isExp (Iface nm md _ _ _ _)
| optCom && isExp -> tyQCon prelude "Maybe" [tyQCon md nm [mkTyConst groundInterface]]
| optCom -> tyQCon md nm [iface_ptr_ty_arg]
{-
Pointer Unique isExp (Iface nm mod _ attrs _ _)
| optJNI && attrs `hasAttributeWithName` "jni_iface_ty" ->
let i = tyVar "a" in
mkTyCon jObject
[ ctxtTyApp (ctxtClass (mkQualName mod nm) [mkTyCon jObject [i]]) i]
| optSubtypedInterfacePointers ->
-- Pointer to anything interface'ish is an interface pointer. Period.
tyQCon prelude "Maybe" [tyQCon mod nm [mkTyConst groundInterface]]
--tyQCon mod nm [iface_ptr_ty_arg]
| otherwise -> tyQCon prelude "Maybe" [tyQConst mod nm]
-}
{- moved down
Pointer _ isExp (Iface nm mod _ attrs _ _)
| optCorba -> tyQCon mod nm [iface_ptr_ty_arg]
-- what's the IU/ID bit? Needed for processing AutoPrim.idl without
-- a hitch. ToDo: remove it.
| optHaskellToC && not (nm `elem` ["IUnknown", "IDispatch"]) -> tyQConst mod nm
| optJNI && attrs `hasAttributeWithName` "jni_iface_ty" ->
let i = tyVar "a" in
mkTyCon jObject
[ ctxtTyApp (ctxtClass (mkQualName mod nm) [mkTyCon jObject [i]]) i ]
| optSubtypedInterfacePointers -> tyQCon mod nm [iface_ptr_ty_arg]
| otherwise -> tyQConst mod nm
-}
Pointer Unique _ (Iface nm md _ attrs _ _)
| optJNI && attrs `hasAttributeWithName` "jni_iface_ty" ->
let i = tyVar "a" in
mkTyCon jObject
[ ctxtTyApp (ctxtClass (mkQualName md nm) [mkTyCon jObject [i]]) i]
| optSubtypedInterfacePointers ->
-- Pointer to anything interface'ish is an interface pointer. Period.
tyQCon prelude "Maybe" [tyQCon md nm [mkTyConst groundInterface]]
--tyQCon md nm [iface_ptr_ty_arg]
| otherwise -> tyQCon prelude "Maybe" [tyQConst md nm]
Pointer _ _ (Iface nm md _ attrs _ _)
| optCorba -> tyQCon md nm [iface_ptr_ty_arg]
-- what's the IU/ID bit? Needed for processing AutoPrim.idl without
-- a hitch. ToDo: remove it.
| optHaskellToC && not (nm `elem` ["IUnknown", "IDispatch"]) -> tyQConst md nm
| optJNI && attrs `hasAttributeWithName` "jni_iface_ty" ->
let i = tyVar "a" in
mkTyCon jObject
[ ctxtTyApp (ctxtClass (mkQualName md nm) [mkTyCon jObject [i]]) i ]
| optSubtypedInterfacePointers -> tyQCon md nm [iface_ptr_ty_arg]
| otherwise -> tyQConst md nm
Pointer pt _ (Name _ _ _ _ _ (Just ti))
| pt /= Ptr && is_pointed ti ->
(\ x ->
if pt == Unique {-&& not (isVARIANTTy x)-} then
tyQCon prelude "Maybe" [x]
else x) $
case mkTyConst (haskell_type ti) of
t | optCom && isTyVar t ->
if isGround then
mkTyConst vARIANT
else
ctxtTyApp (ctxtClass variantClass [t]) t
| otherwise -> t
Pointer pt _ t
| pt /= Ptr && isFunTy t -> toHaskellTy isGround t
Pointer Ptr _ (Name _ _ _ (Just as) _ _)
| as `hasAttributeWithName` "foreign" -> tyForeignObj
Pointer _ _ t | isVoidTy t || (isConstructedTy t && isReferenceTy t) -> tyAddr
Pointer pt _ t
| pt == Ref || (optHaskellToC && isIfaceTy t) ->
if isIfaceTy t then
toHaskellTy isGround (getIfaceTy t)
else
toHaskellTy isGround t
| pt == Unique ->
tyQCon prelude "Maybe" $
case t of
Void -> [tyAddr]
_
-- optDeepMarshall -> [tyPtr (toHaskellTy isGround ty)]
| optCom && isIfaceTy t -> [toHaskellTy isGround (getIfaceTy t)]
| otherwise -> [toHaskellTy isGround t] -- is this right?
| isVariantTy t -> toHaskellTy isGround t
| otherwise -> -- assumed to be a pure/raw pointer
tyPtr (toHaskellTy isGround t)
Struct i _ _ -> tyConst' i
Union u _ _ _ _ -> tyConst' u
CUnion u _ _ -> tyConst' u
UnionNon u _ -> tyConst' u
Enum i _ _ -> tyConst' i
Iface{} -> toHaskellIfaceTy ty
_ -> error ("toHaskellTy: "++showCore (ppType ty))
where
iface_ptr_ty_arg = tyVar "a"
tyConst' i = tyQConst
(idHaskellModule i)
(mkHaskellTyConName (idName i))
\end{code}
%*
%
<sect>Mapping <tt/structs/ to Haskell types</sect>
<label id="sec:type:struct:translate">
%
%*
We derive a Haskell type from a @struct@ as follows:
struct Tag { [a1]f_1 : t1; [a2]f_2:t2; [a_n]f_3:t_n; }
===> data _ = Tag { h_1 :: T1, ... h_m :: Tm }
<itemize>
<item> if f_i is not the size/length specifier of another
field, it is added as a labelled field to the Haskell
data type (converting the field name and type, first)
<item>if f_i is a size/length specifier for another field, it
is not directly represented in the generated type.
Instead, the struct member that is the dependent of
f_i is turned into a list. (We probably will need to
add a flag that controls this rewrite.)
<item>If @f_i@ is a switch id/tag for a non-encapsulated union, we
leave the tag as a member of the struct, since it is useful on
its own, and does in some cases contain more tag values than that
used by the union (cf. the mysterious default union tag.)
</itemize>
\begin{code}
mkHStructDef :: Id -> [Field] -> Haskell.ConDecl
mkHStructDef tg fields =
recCon (mkHaskellTyConName (idName tg))
(map mkField fields')
where
mkField (i, t) = ( mkHaskellVarName (idName i), t)
dep_list = findFieldDependents fields
-- any dependees apart from the switch_is() ones, which
-- we keep.
dependees = map (idName.fieldId) $
filter (\ f -> isNotSwitchDependee dep_list (fieldId f) &&
not (isVoidPointerTy (fieldType f)))
fields
dependers = map (idName.fst) (filter (notNull.snd) dep_list)
fields' =
map convDependees $
-- remove the size fields
filter (\ f -> notElem (idName (fieldId f)) dependees) fields
convDependees f
| (idName i) `elem` dependers =
let r_ty = removeNames ty in
case r_ty of
Array _ _ -> (i, toHaskellTy True ty)
Pointer _ _ Void -> (i, toHaskellTy True r_ty)
Pointer{} -> (i, tyList (toHaskellTy True (removeNames (removePtr r_ty))))
_ -> (i, toHaskellTy True ty)
| otherwise = (i, toHaskellTy True ty)
where
i = fieldId f
ty = fieldOrigType f
mkHEnumDef :: Name -> [Attribute] -> EnumKind -> [EnumValue] -> [Haskell.ConDecl]
mkHEnumDef enumTag attrs kind vals = addList (map mkCon vals)
where
addList =
case kind of
EnumFlags{} -> (listCon:)
_
| optEnumsAsFlags || asFlag -> (listCon:)
| otherwise -> id
asFlag = attrs `hasAttributeWithName` "hs_flag"
listCon = conDecl (mkHaskellTyConName (enumTag ++ "List__"))
[tyList (tyCon (mkHaskellTyConName enumTag) [])]
mkCon ev = conDecl (mkHaskellTyConName (idName i))
tys
where
i = enumName ev
tys =
(\ x ->
case x of
[] -> []
xs -> [tyCon xs []]) $
unwords $
map (\ xs -> '(':xs ++ ")") $
map getStr $
filterAttributes (idAttributes i)
["hs_tyarg"]
getStr (Attribute _ [ParamLit (StringLit s)]) = s
getStr _ = ""
mkHUnionDef :: Name -> [Switch] -> [Haskell.ConDecl]
mkHUnionDef nm switches = concatMap mkCon switches
where
mkCon (SwitchEmpty Nothing) = [conDecl (mkHaskellTyConName (nm ++ "_Anon")) []]
mkCon (SwitchEmpty (Just ls)) =
map (\ x -> conDecl (mkHaskellTyConName (nm ++ x)) []) ls_nm
where
ls_nm = map snd ls
mkCon sw =
[conDecl (mkHaskellTyConName (idName (switchId sw)))
[toHaskellTy True (switchOrigType sw)]]
mkCUnionDef :: [Field] -> [Haskell.ConDecl]
mkCUnionDef fields = map mkCon fields
where
mkCon f =
conDecl (mkHaskellTyConName (idName (fieldId f)))
[toHaskellTy True (fieldOrigType f)]
\end{code}
\begin{code}
paramToHaskellType :: DependInfo -> Bool -> Bool -> Bool -> Param -> Haskell.Type
paramToHaskellType deps isServer isAuto isResult p
| no_dependees && not keep_external = mkHaskellTy ty
| keep_external = mkHaskellTy ty'
| otherwise = real_ty
where
nm = paramId p
attrs = idAttributes nm
-- Note: we need to use the paramType rather than the
-- original type when peeling of a layer of pointers,
-- because the orig. type might be a straight synonym.
-- (the peeling function could look through names to avoid
-- this, but it doesn't at the moment.)
ty
| peel = removePtrAndArray (paramType p)
| otherwise = paramOrigType p
dependees = fromMaybe [] (lookupDepender deps nm)
no_dependees = null dependees
ty' = mkPtrPointer ty
keep_external =
attrs `hasAttributeWithName` "ptr" ||
(not isResult && keepValueAsPointer ty)
mkHaskellTy t
| attrs `hasAttributeWithName` "foreign" = tyForeignObj
| isAuto && paramMode p == In &&
attrs `hasAttributeWithName` "optional" =
if optOptionalAsMaybe then
tyQCon prelude "Maybe" [autoTypeToHaskellTy pkind t]
else
overloadedTyVar variantClass "a"
| isAuto = autoTypeToHaskellTy pkind t
| otherwise =
(if isOut &&
not (attrs `hasAttributeWithName` "iid_is")
then groundTyVars else id) $ toHaskellTy isServer t
real_ty = go sizes ty
go (_:xs) acc
| isVoidPointerTy (removeNames acc) = tyAddr
| isPointerOrArrayTy (removeNames acc) = tyList (go xs (removePtrAndArray (removeNames acc)))
go _ acc =
(if isOut &&
not (attrs `hasAttributeWithName` "iid_is")
then groundTyVars else id) $ toHaskellTy isServer acc
(sizes, peel) =
case computeArrayConstraints False{-not unmarshalling-} dependees of
(_,_,cs) ->
case cs of
(DepNone:cs1) | isOut -> (cs1, True)
-- (_:cs) | isOut -> (cs, True)
_ -> (cs, False)
pkind = paramMode p
isOut =
case pkind of
Out -> True
_ -> False
\end{code}
Convert an IDL type into its corresponding Haskell <em/primitive/ representation.
The primitive representation of a type is the representation expected externally.
For example,
typedef [unique]char* pchar;
is to the Haskell programmer represented as
type Pchar = Maybe Char
the primitive representation of this unique pointer is an Addr (not such a big surprise),
which is what we pass to an external function expecting a @pchar@ as argument.
@toHaskellBaseTy@ implements the B scheme in the H/Direct paper.
\begin{code}
toHaskellBaseTy :: Bool -> Type -> Haskell.Type
toHaskellBaseTy isResult ty =
case ty of
Integer sz s -> mkIntTy sz s
Float sz -> mkFloatTy sz
Char signed -> mkCharTy signed
WChar -> tyWChar
Bool -> mkIntTy Long True
Void -> tyUnit
Octet -> tyWord8
Any -> tyAddr
Object -> tyAddr
String{} -> tyPtr tyString
WString{} -> tyPtr tyWString
FunTy{} -> tyPtr (toHaskellTy False ty) -- (-- the toplevel type --)
StablePtr -> tyStable
Sequence{} -> tyAddr --error "toHaskellBaseTy.Sequence: not implemented yet."
Fixed{} -> error "toHaskellBaseTy.Fixed: not implemented yet."
Name _ _ _ _ _ (Just ti)
| not isResult && {- not (is_pointed ti) && -} finalised ti -> tyForeignObj
Name n _ _ _ mb_orig_ty mb_ti ->
case mb_ti of
Just ti -> (if isResult then toPtrTy else id) $ prim_type ti
Nothing ->
case mb_orig_ty of
Nothing ->
trace ("toHaskellBaseTy: Warning, defaulting " ++ show n ++ "to Addr")
tyAddr
Just t -> toHaskellBaseTy isResult t
Pointer _ _ (Name _ _ _ _ _ (Just ti))
| not isResult && is_pointed ti && finalised ti ->
prim_type ti
| otherwise -> (if not (is_pointed ti) && not (isPtrTy (prim_type ti))
then tyPtr else id) $ ((if isResult then toPtrTy else id) $ prim_type ti)
Pointer _ _ i@(Iface nm _ _ attrs _ _)
| not isResult ->
if not optHaskellToC ||
attrs `hasAttributeWithName` "finaliser" ||
nm `elem` ["IUnknown" , "IDispatch"] -- fudge
then
tyForeignPtr (toHaskellIfaceTy i)
else
tyPtr (toHaskellIfaceTy i)
| otherwise -> tyPtr (toHaskellIfaceTy i)
Pointer _ _ (Name n _ m _ _ _) ->
tyPtr (tyQConst (fmap mkHaskellTyConName m) (mkHaskellTyConName n))
Pointer _ _ t -> tyPtr (toHaskellBaseTy isResult t)
Iface{} -> toHaskellBaseTy isResult (Pointer Ref True ty)
Array t _ -> tyPtr (toHaskellBaseTy isResult t)
SafeArray _
| isResult -> tyPtr (mkTyConst sAFEARRAY)
| otherwise -> tyForeignPtr (mkTyConst sAFEARRAY)
Struct i [f] _
| isSimpleTy (fieldType f) ||
((idAttributes i) `hasAttributeWithName` "hs_newtype")
-> toHaskellBaseTy isResult (fieldType f)
Struct{} -> tyAddr -- liar!
Union{} -> tyAddr
CUnion{} -> tyAddr
UnionNon{} -> tyAddr
Enum{} -> tyInt32
_ -> error ("toHaskellBaseTy: not handled" ++ showCore (ppType ty))
toBaseTy :: Type -> Type
toBaseTy ty =
case ty of
Bool -> int32Ty
Octet -> charTy
String{} -> addrTy
WString{} -> addrTy
Sequence{} -> addrTy
FunTy{} -> addrTy
-- ToDo: get rid of this.
Name "VARIANT_BOOL" _ _ _ _ _ | optCom -> ty
Name _ _ _ _ Nothing _ -> addrTy -- your guess is as good as mine.
Name _ _ _ _ (Just t) _ -> toBaseTy t
Struct i [f] _
| isSimpleTy (fieldType f) ||
((idAttributes i) `hasAttributeWithName` "hs_newtype")
-> toBaseTy (fieldType f)
Struct{} -> addrTy
Enum{} -> int32Ty
Union{} -> int32Ty
UnionNon{} -> int32Ty
CUnion{} -> int32Ty
Pointer _ _ t
| isIfaceTy t -> ty
| otherwise -> addrTy
Array{} -> addrTy
SafeArray{} -> addrTy
_ -> ty
\end{code}
Provide the 'direct' mapping of a method/function.
\begin{code}
toHaskellBaseMethodTy :: Bool -> [Param] -> Result -> Haskell.Type
toHaskellBaseMethodTy isRes ps res
= case generaliseTys (res_ty : p_tys) of
((r:ps1), mb_c) -> mbCtxtTyApp mb_c (funTys ps1 r)
where
res_ty = io (toPtrTy (toHaskellBaseTy True (resultType res)))
p_tys = map (toPtrTy.(toHaskellBaseTy isRes).paramType) ps
\end{code}
\begin{code}
mkMarshaller :: String -> Type -> QualName
mkMarshaller pre ty =
case ty of
Name _ _ _ _ (Just t@(Name{})) _ -> mkMarshaller pre t
Name _ _ _ _ (Just t) _ | not (isConstructedTy t) -> mkMarshaller pre t
Name n _ md _ _ _ -> mkQVarName md (pre ++ mkHaskellTyConName n)
Struct i [] _ -> mkQVarName (idModule i) (pre ++ mkHaskellTyConName (idName i))
-- _ -> appHTy pre (toHaskellBaseTy False ty)
-- _ -> mkQVarName Nothing ("(" ++ pre ++ " " ++ (PPHaskell.showAbstractH (ppType ty)) ++ ")")
_ -> prefixHTy pre (toHaskellBaseTy False ty)
\end{code}
\begin{code}
autoTypeToHaskellTy :: ParamDir -> Type -> Haskell.Type
autoTypeToHaskellTy pkind ty =
case mbAutoTypeToHaskellTy pkind ty of
Just x -> x
Nothing ->
trace ("autoTypeToHaskellType: unknown auto type "++ showCore (ppType ty) ++ "\n Giving it a variant type") $
(overloadedTyVar variantClass "a")
mbAutoTypeToHaskellTy :: ParamDir -> Type -> Maybe Haskell.Type
mbAutoTypeToHaskellTy pkind ty =
case ty of
-- Note: we disregard the '[unique]' flag on the string types here;
-- Automation doesn't support [unique].
String{} -> Just $ mkTyConst $ mkQualName prelude stringName
WString{} -> Just $ mkTyConst $ mkQualName prelude stringName
Integer sz isSigned ->
case sz of
Short
| isSigned -> Just $ mkTyConst $ tyInt16Name
| otherwise -> Just $ mkTyConst $ tyWord16Name
Long
| isSigned -> Just $ mkTyConst $ tyInt32Name
| otherwise -> Just $ mkTyConst $ tyWord32Name
Natural
| optIntIsInt && isSigned -> Just $ mkTyConst $ tyIntName
| isSigned -> Just $ mkTyConst $ tyInt32Name
| otherwise -> Just $ mkTyConst $ tyWord32Name
LongLong
| optLongLongIsInteger -> Just $ mkTyConst $ tyIntegerName
| isSigned -> Just $ mkTyConst $ tyInt64Name
| otherwise -> Just $ mkTyConst $ tyWord64Name
Char{} -> Just $ mkTyConst $ mkQualName prelude "Char" -- dodgy, but it works..
Octet -> Just $ mkTyConst $ mkQualName prelude "Char"
Bool -> Just $ mkTyConst $ mkQualName prelude "Bool"
Float sz ->
case sz of
Short -> Just $ mkTyConst $ mkQualName prelude "Float"
Long -> Just $ mkTyConst $ mkQualName prelude "Double"
LongLong -> Just $ mkTyConst $ mkQualName prelude "Double"
Natural -> Just $ mkTyConst $ mkQualName prelude "Float"
Pointer _ _ (Iface "IUnknown" _ _ _ _ _) -> Just (mkIType iUnknown)
Pointer _ _ (Iface "IDispatch" _ _ _ _ _) -> Just (mkIType iDispatch)
Pointer _ _ (Iface nm md _ _ _ _) -> Just $ mkIType $ mkQualName md (mkIfaceTypeName nm)
Pointer _ _ Void -> Just varTy
Pointer _ _ (Name _ _ _ _ _ (Just ti))
| is_pointed ti -> Just (mkAutoTyConst (auto_type ti))
Iface "IUnknown" _ _ _ _ _ -> Just $ mkIType iUnknown
Iface "IDispatch" _ _ _ _ _ -> Just $ mkIType iDispatch
Iface nm md _ _ _ _ -> Just $ mkIType $ mkQualName md (mkIfaceTypeName nm)
SafeArray t ->
case mbAutoTypeToHaskellTy Out{-want to ground any embedded iface-pointers-} t of
Nothing -> Nothing
-- Just x -> Just $ mkTyCon (mkQualName autoLib "SafeArray") [groundTyVars x]
Just x -> Just $ mkTyCon (mkQualName autoLib "SafeArray") [x]
(Name "HRESULT" _ _ _ _ _) -> Just $ mkTyConst $ mkQualName comLib "HRESULT"
(Name "VARIANT_BOOL" _ _ _ _ _) -> Just $ mkTyConst $ mkQualName prelude "Bool"
-- (Name "VARIANT" _ _ _ _ _) -> Just varTy
{- BEGIN_SUPPORT_TYPELIBS
(Name _ _ _ _ _ (Just ti)) | isJust (auto_vt ti) -> Just $ mkAutoTyConst (auto_type ti)
END_SUPPORT_TYPELIBS -}
(Name nm _ md _ (Just Enum{}) _) -> Just $ mkTyConst $ mkQualName md (mkHaskellTyConName nm)
(Name _ _ _ _ (Just orig_ty) _) -> mbAutoTypeToHaskellTy pkind orig_ty
(Name _ _ _ _ _ (Just ti)) -> Just (mkTyConst $ haskell_type ti)
Name{} -> Nothing
Pointer _ _ t -> mbAutoTypeToHaskellTy pkind t
Enum{} -> Just $ mkTyConst $ mkQualName prelude "Int"
--As if by magic..
(Struct (Id {idName="TagVARIANT"}) _ _) -> Just varTy
_ -> Nothing
where
-- leave these as a type variable, later pass will constrain
-- it with the approp. context.
varTy = overloadedTyVar variantClass "a"
isOut = pkind == Out
mkIType qv
| optSubtypedInterfacePointers && isOut = mkTyCon qv [mkTyConst groundInterface]
| optSubtypedInterfacePointers = mkTyCon qv [tyVar "a"]
| otherwise = mkTyCon qv [tyVar "a"]
{-
Type variables are Variant-overloaded.
-}
mkAutoTyConst :: QualName -> Haskell.Type
mkAutoTyConst q =
case mkTyConst q of
t | isTyVar t -> ctxtTyApp (ctxtClass variantClass [t]) t
| otherwise -> t
autoTypeToQName :: Type -> QualName
autoTypeToQName ty =
case ty of
String{} -> mkQualName prelude "String"
WString{} -> mkQualName prelude "String"
Integer sz isSigned ->
case sz of
Short
| isSigned -> tyInt16Name
| otherwise -> tyWord16Name
Long
| isSigned -> tyInt32Name
| otherwise -> tyWord32Name
Natural
| optIntIsInt && isSigned -> tyIntName
| isSigned -> tyInt32Name
| otherwise -> tyWord32Name
LongLong
| optLongLongIsInteger -> tyIntegerName
| isSigned -> tyInt64Name
| otherwise -> tyWord64Name
Char{} -> mkQualName prelude "Char" -- dodgy, but it works.. (don't take signedness into account, nor the size of a Haskell Char)
Octet -> mkQualName prelude "Char"
Bool -> mkQualName prelude "Bool"
Float sz ->
case sz of
Short -> mkQualName prelude "Float"
Long -> mkQualName prelude "Double"
LongLong -> mkQualName prelude "Double"
Natural -> mkQualName prelude "Float"
Iface _ _ _ _ is_idis _
| is_idis -> iDispatch
| otherwise -> iUnknown
Pointer _ _ Void -> mkQualName autoLib "Variant"
SafeArray{} -> mkQualName autoLib "SafeArray"
(Name "HRESULT" _ _ _ _ _) -> mkQualName comLib "HRESULT"
-- hack
-- (Name "LPSTR" _ _ _ _ _) -> mkQualName prelude stringName
Name _ _ _ _ _ (Just ti)
| isTyVar (mkTyConst (auto_type ti)) -> mkQualName autoLib "Variant"
| otherwise -> auto_type ti
Name _ _ _ _ (Just orig_ty) _ -> autoTypeToQName orig_ty
Name nm _ _ _ _ _ ->
trace ("warning: found type name " ++ show nm ++ " but not its defn.") $
mkQualName autoLib "Variant"
Pointer _ _ (Name _ _ _ _ _ (Just ti))
| is_pointed ti ->
let at = auto_type ti in
if isTyVar (mkTyConst at) then
mkQualName autoLib "Variant"
else
at
Pointer _ _ t -> autoTypeToQName t
Enum{} -> mkQualName autoLib "Enum"
(Struct (Id {idName="TagVARIANT"}) _ _) -> mkQualName autoLib "Variant" -- hmm..
_ -> trace ("autoTypeToQName: unknown auto type "++ showCore (ppType ty) ++ "\n Giving it a variant type") $
mkQualName autoLib "Variant"
\end{code}