Hs2lib-0.4.8: WinDll/Lib/NativeMapping.hs
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Windll
-- Copyright : (c) Tamar Christina 2009 - 2010
-- License : BSD3
--
-- Maintainer : tamar@zhox.com
-- Stability : experimental
-- Portability : portable
--
-- Contains the list of native types and their mapping to their equivalent FFI types
--
-----------------------------------------------------------------------------
module WinDll.Lib.NativeMapping where
import FastString
import FastTypes
import Foreign
import Foreign.C
import Foreign.C.String
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.StablePtr
import Unsafe.Coerce
import Control.Exception (bracket)
import Control.Monad
import Control.Monad.Instances
import Data.Char
import Data.List
import Data.Word
import Data.Generics
import Data.Generics.Basics
import Data.Typeable
import WinDll.Structs.Types
import WinDll.Lib.Native
import qualified Language.Haskell.Exts as Exts
-- | Typeclase to allow Left LoaD transform. It is basically to allow a transformation to take place
-- at the last argument/return type of the function. This is because most of the functions are in IO.
class LLD m a b c | b -> c where
lld :: m a b-> m a c
instance LLD (->) a b (IO b) where
lld = (return .)
-- | A class that manages the conversion between the \normal\ and type supported by \ffi\.
-- Minimal implementation requires atleast one of the pair toNative/toFFI and fromNative/fromFFI.
-- The implementation will almost always call fromNative and toNative because all exported functions
-- are in IO since they all might have side-effects. The only exception to this is for the defaults provided
-- in this module.
class FFIType phi ix where
toFFI :: phi -> ix
toFFI = error "toFFI is undefined for the specified type, try toNative instead."
fromFFI :: ix -> phi
fromFFI = error "fromFFI is undefined for the specified type, try fromNative instead."
fromList :: CInt -> ix -> IO phi
fromList ic = error "fromList is undefined for this type. Please add a definition or consider using one of the default ones"
fromNative :: ix -> IO phi
fromNative = return.fromFFI
toNative :: phi -> IO ix
toNative = return.toFFI
freeFFI :: phi -> ix -> IO ()
freeFFI = \_ _ -> return ();
-- | Default values needed to satisfy .NET marshaller when having unused structures.
-- class FFIType phi ix => FFIDefaults phi ix where
-- class Default phi where
-- nDefault :: phi
-- instance Data a => Default a where
-- nDefault = empty
-- where empty :: Data a => a
-- empty = value
-- where
-- value = fromConstrB empty con
-- con = case dataTypeRep dat of
-- (AlgRep cons) -> head cons
-- IntRep -> mkIntegralConstr dat 0
-- FloatRep -> mkRealConstr dat 0
-- CharRep -> mkCharConstr dat 'a'
-- dat = dataTypeOf value
-- | Wrapper functions for dealing with FunPtrs
-- wrapFn :: (FFIType (IO a) ca, FFIType b (IO cb)) => (a -> IO b) -> (ca -> IO cb)
-- wrapFn fn = fromFFI >=> fn >=> toFFI
-- unwrapFn :: (FFIType a (IO ca), FFIType (IO b) cb) => (ca -> IO cb) -> (a -> IO b)
-- unwrapFn fn a = bracket (toFFI a) (freeFFI undefined) (fn >=> fromFFI)
-- | Dedicated instance for ()
instance FFIType () () where
toFFI = id
fromFFI = id
-- | Numeral values are all also already FFI values, If I've read the documentation correctly
-- Due to GHC matching only the instance heads this instance can't unfortunately be used. (Booo bad GHC)
-- instance Num a => FFIType a a where
-- toFFI = id
-- fromFFI = id
-- | Booleans are by default already an FFI value
instance FFIType Bool Bool where
toFFI = id
fromFFI = id
-- | Convert booleans to Cints for use when using the ccall or stdcall conventions
instance FFIType Bool CInt where
toFFI False = 0
toFFI True = 1
fromFFI 0 = False
fromFFI 1 = True
-- | Convert booleans to Word8 to save space for use when using the ccall or stdcall conventions
instance FFIType Bool Word8 where
toFFI False = 0
toFFI True = 1
fromFFI 0 = False
fromFFI 1 = True
-- | Convert booleans to Int8 to save space for use when using the ccall or stdcall conventions
instance FFIType Bool Int8 where
toFFI False = 0
toFFI True = 1
fromFFI 0 = False
fromFFI 1 = True
-- | A StorablePtr instance
instance FFIType (StablePtr a) (StablePtr a) where
fromFFI = id
toFFI = id
freeFFI _ = freeStablePtr
-- | A FunPtr instance
instance FFIType (FunPtr a) (FunPtr a) where
fromFFI = id
toFFI = id
freeFFI _ = freeHaskellFunPtr
-- | Tranform functions to and from the correct types
instance (FFIType a b, FFIType c d) => FFIType (a -> c) (b -> d) where
toFFI f x = toFFI (f (fromFFI x))
fromFFI f x = fromFFI (f (toFFI x))
-- | I decided to use a CAString because on windows this gives me a constant 16 value
instance FFIType String CWString where
toNative = newCWString
fromNative = peekCWString
-- | Intermediate conversion instance for storing values of arrays
instance (Storable a, FFIType b a) => FFIType [b] (Ptr a) where
toNative = newArray . map toFFI
fromList x = fmap (map fromFFI) . peekArray (fromFFI x)
-- | Another simple identityy instance, I really need to get that overlapping instances
-- looked at.
instance FFIType CWchar CWchar where
toFFI = id
fromFFI = id
-- | Another simple identityy instance, I really need to get that overlapping instances
-- looked at.
instance FFIType CWString CWString where
toFFI = id
fromFFI = id
-- | Another simple identityy instance, I really need to get that overlapping instances
-- looked at.
instance FFIType CInt CInt where
toFFI = id
fromFFI = id
-- | Another simple identityy instance, I really need to get that overlapping instances
-- looked at.
instance FFIType CDouble CDouble where
toFFI = id
fromFFI = id
-- | Another simple identityy instance, I really need to get that overlapping instances
-- looked at.
instance FFIType CLLong CLLong where
toFFI = id
fromFFI = id
-- | Convert between FastString and CWString
instance FFIType FastString CWString where
toFFI = toFFI.unpackFS
fromFFI = mkFastString.fromFFI
-- | Fix integers from the machine dependend values to fixed 32bit values
instance FFIType Int CInt where
toFFI = fromIntegral
fromFFI = fromIntegral
-- | Instance for unboxed integers, which are first boxed then returned
-- instance FFIType FastInt CInt where
-- toFFI = toFFI . iBox
-- fromFFI = iUnbox . fromFFI
-- | Fix float instances
instance FFIType Float CFloat where
toFFI = realToFrac
fromFFI = realToFrac
-- | Any class implementing Storable has implemented enough to be considered a FFIType
instance Storable a => FFIType a (Ptr a) where
toNative = new
fromNative = peek
-- | Cover lists to array convertion IF the type is also an FFI type
instance Storable a => FFIType [a] (Ptr a) where
toNative = newArray --fmap castPtr . new -- newArray
fromList = peekArray . fromFFI --const (peek . castPtr) --peekArray
-- | Intermediate conversion instance for storing values of arrays
-- | One way instance for returning lists as the result of a function call.
-- We assume to have an int* as an argument and then fill that in with the
-- length
instance (FFIType a b, Storable b) => FFIType [a] (Ptr CInt -> IO (Ptr b)) where
toNative lst = let ln = length lst
in return $ \t -> do poke t (toFFI ln)
toNative lst
fromNative fn = do ptr <- malloc
lst <- fn ptr
ln <- peek ptr
val <- fromList ln lst
free ptr
free lst
return $ val
-- | Simplistic instance of Storable for list.
-- untested but (new [(1::Int)..10] >>=return.castPtr >>= peekArray 10 :: IO [Int]) works
instance Storable a => Storable [a] where
sizeOf _ = 4
alignment _ = 4
poke ptr value = do newptr <- newArray value
copyArray (castPtr ptr) newptr (length value)
peekElemOff ptr c = do val <- peekArray c (castPtr ptr)
free ptr
return val
-- | Convertion instance for Integer types to CLLongs (long long)
instance (Num a,Integral a) => FFIType Integer a where
toFFI = fromInteger
fromFFI = toInteger
-- | Instance for Functor classes
instance (Functor f, FFIType a b) => FFIType (f a) (f b) where
toFFI = fmap toFFI
fromFFI = fmap fromFFI
-- -- | Instance for Functor classes directly to pointers
{- instance (Functor f, FFIType a b,Storable (f b)) => FFIType (f a) (Ptr (f b)) where
toNative x = new (toFFI x)
fromNative _ x = fmap fromFFI (peek x)
-}
instance FFIType Char CChar where
toFFI = castCharToCChar
fromFFI = castCCharToChar
instance FFIType Rational CDouble where
toFFI = fromRational
fromFFI = toRational
instance FFIType Char CWchar where
toFFI = head.charsToCWchars.(:[])
where
charsToCWchars = foldr utf16Char [] . map ord
where
utf16Char c wcs
| c < 0x10000 = fromIntegral c : wcs
| otherwise = let c' = c - 0x10000 in
fromIntegral (c' `div` 0x400 + 0xd800) :
fromIntegral (c' `mod` 0x400 + 0xdc00) : wcs
fromFFI = head.cWcharsToChars.(:[])
where
cWcharsToChars = map chr . fromUTF16 . map fromIntegral
where
fromUTF16 (c1:c2:wcs)
| 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff =
((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs
fromUTF16 (c:wcs) = c : fromUTF16 wcs
fromUTF16 [] = []
-- | Tuples are not FFI compatible, As such i'll translate them to a build in tuple datatype
-- .
-- This function translates the embedded types of a Ty to the correct forms using the
-- function translate' (see below)
translate :: Defs -> Type -> Type
translate defs = everywhere (mkT inner)
where inner :: Exts.Name -> Exts.Name
inner (Exts.Ident s) = Exts.Ident (translate' defs s)
inner (Exts.Symbol s) = Exts.Symbol (translate' defs s)
-- | Translate everything but applied types. e.g. Foo Token -> FooPtr Token
-- And lists, since lists are implicitly an applied type:
-- e.g [Token] -->> [] Token -->> Ptr Token
translatePartial :: Defs -> Type -> Type
translatePartial defs (Exts.TyForall a b c) = Exts.TyForall a b (translatePartial defs c)
translatePartial defs (Exts.TyFun a b) = Exts.TyFun (translatePartial defs a) (translatePartial defs b)
translatePartial defs (Exts.TyTuple a b) = Exts.TyTuple a (map (translatePartial defs) b)
translatePartial defs (Exts.TyList a) = Exts.TyList $ case isSimpleType a of
True -> translatePrimitive defs a
False -> a
translatePartial defs (Exts.TyApp a b) = case findStrings' a of
("IO":_) -> Exts.TyApp (translatePartial defs a) (translatePartial defs b)
_ -> Exts.TyApp (translatePartial defs a) b
translatePartial defs (Exts.TyParen a) = Exts.TyParen (translatePartial defs a)
translatePartial defs (Exts.TyInfix a b c) = Exts.TyInfix (translatePartial defs a) b (translatePartial defs c)
translatePartial defs (Exts.TyKind a b) = Exts.TyKind (translatePartial defs a) b
translatePartial defs x = translate defs x
-- | Check to see if the next type is a Simple type. e.g. A TyVar or TyCon
isSimpleType :: Type -> Bool
isSimpleType (Exts.TyApp _ _ ) = False
isSimpleType (Exts.TyParen a ) = isSimpleType a
-- isSimpleType (Exts.TyList _ ) = False
isSimpleType _ = True
-- | Contrary to translate translatePrimitive will only transform the defined
-- primitive types in the \convList\ below. This is because while a transformed
-- signature should only be partially transformed till the first application (Since that'll be
-- the main pointer) we should pre-transform the primitive types into their well known static forms.
translatePrimitive :: Defs -> Type -> Type
translatePrimitive defs = everywhere (mkT inner)
where inner :: Exts.Name -> Exts.Name
inner (Exts.Ident s) = Exts.Ident (translateP defs s)
inner (Exts.Symbol s) = Exts.Symbol (translateP defs s)
-- | Helper function to define translatePrimitive. It attemps to lookup the type in \convList\ but
-- in the case where it's not found the search query is returned.
translateP :: Defs -> String -> String
translateP convList x =
let sType = all isLower x
in if sType then x else maybe x id (lookup x convList)
-- | Translate Partial Form, This is basically translatePrimitive . translatePartial
translatePForm :: Defs -> Type -> Type
translatePForm df = translatePrimitive df . translatePartial df
-- | Look up the FFI type representation of the given type. Moreover when the type is not found
-- it is assumed to be a new structure and it is assumed to be a pointer value.
translate' :: Defs -> String -> String
translate' convList x = let sType = all isLower x
in if sType then x else ((flip maybe id . (++ "Ptr")) `ap` (flip lookup convList)) x
-- | Remove all spaces from a sentence
trim :: String -> String
trim = filter (/=' ')
-- | A function to split a list of elements by the given seperator
split :: Eq a => [a] -> a -> [[a]]
split [] _ = [[]]
split (x:xs) t | t==x = [] : (split xs t)
| otherwise = let (f:fs) = split xs t
in (x:f):fs