# 1 "WinDll/Lib/NativeMapping.cpphs"
# 1 "<built-in>"
# 1 "<command-line>"
# 10 "<command-line>"
# 1 "./dist/build/autogen/cabal_macros.h" 1
# 10 "<command-line>" 2
# 1 "WinDll/Lib/NativeMapping.cpphs"
# 1 "WinDll/Lib/NativeMapping_Base.cpphs" 1
module WinDll.Lib.NativeMapping where
import FastString
import FastTypes
import Foreign.C
import Foreign.C.String
import Foreign
import Foreign.Marshal.Alloc
import qualified Foreign.Marshal.Alloc as F
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
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 .)
class FFIType phi ix where
# 111 "WinDll/Lib/NativeMapping_Base.cpphs"
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 ();
# 173 "WinDll/Lib/NativeMapping_Base.cpphs"
instance FFIType () () where
toFFI = id
fromFFI = id
instance FFIType Bool Bool where
toFFI = id
fromFFI = id
instance FFIType Bool CInt where
toFFI = (\x-> case x of
False -> 0
True -> 1)
fromFFI = (\x-> case x of
0 -> False
1 -> True)
instance FFIType Bool Word8 where
toFFI = (\x-> case x of
False -> 0
True -> 1)
fromFFI = (\x-> case x of
0 -> False
1 -> True)
instance FFIType Bool Int8 where
toFFI = (\x-> case x of
False -> 0
True -> 1)
fromFFI = (\x-> case x of
0 -> False
1 -> True)
instance FFIType (StablePtr a) (StablePtr a) where
toFFI = id
fromFFI = id
freeFFI _ = freeStablePtr
instance FFIType (FunPtr a) (FunPtr a) where
toFFI = id
fromFFI = id
freeFFI _ = freeHaskellFunPtr
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))
instance FFIType String CWString where
toNative = newCWString
fromNative ptr = (\ptr -> return ( id ptr)) ptr
>> peekCWString ptr
>>= \str -> freeFFI "" ptr
>> return str
freeFFI = \_ -> F.free
instance (Storable a, FFIType b a) => FFIType [b] (Ptr a) where
toNative = ( newArray) . map (toFFI )
fromList x = fmap (map (fromFFI )) . (\ptr -> return ( id ptr) >>= peekArray (fromFFI x))
instance FFIType CWchar CWchar where
fromFFI = id
toFFI = id
instance FFIType CWString CWString where
fromFFI = id
toFFI = id
instance FFIType CInt CInt where
toFFI = id
fromFFI = id
instance FFIType CDouble CDouble where
toFFI = id
fromFFI = id
instance FFIType CLLong CLLong where
toFFI = id
fromFFI = id
instance FFIType FastString CWString where
toFFI = toFFI .unpackFS
fromFFI = mkFastString.fromFFI
instance FFIType Int CInt where
toFFI = fromIntegral
fromFFI = fromIntegral
instance FFIType Float CFloat where
toFFI = realToFrac
fromFFI = realToFrac
instance Storable a => FFIType a (Ptr a) where
toNative = new
fromNative = \ptr -> return ( id ptr) >>= peek
freeFFI = \_ -> F.free
instance Storable a => FFIType [a] (Ptr a) where
toNative = newArray
fromList = peekArray . fromFFI
freeFFI = \_ -> F.free
instance (FFIType a b, Storable b) => FFIType [a] (Ptr CInt -> IO (Ptr b)) where
# 337 "WinDll/Lib/NativeMapping_Base.cpphs"
toNative lst = let ln = length lst
in return $ \t -> do ln' <- toNative ln
poke t ln'
toNative lst
fromNative fn = do ptr <- malloc
lst <- fn ptr
ln <- peek ptr
val <- fromList ln lst
F.free ptr
F.free lst
return $ val
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)
F.free ptr
return val
instance (Num a,Integral a) => FFIType Integer a where
toFFI = fromInteger
fromFFI = toInteger
instance (Functor f, FFIType a b) => FFIType (f a) (f b) where
toFFI = fmap (toFFI )
fromFFI = fmap (fromFFI )
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 [] = []
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)
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
isSimpleType :: Type -> Bool
isSimpleType (Exts.TyApp _ _ ) = False
isSimpleType (Exts.TyParen a ) = isSimpleType a
isSimpleType _ = True
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)
translateP :: Defs -> String -> String
translateP convList x =
let sType = all isLower x
in if sType then x else maybe x id (lookup x convList)
translatePForm :: Defs -> Type -> Type
translatePForm df = translatePrimitive df . translatePartial df
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
trim :: String -> String
trim = filter (/=' ')
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
# 4 "WinDll/Lib/NativeMapping.cpphs" 2