% % (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} %* % Mapping