# 1 "WinDll/Lib/NativeMapping_Debug.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_Debug.cpphs"
# 1 "WinDll/Lib/NativeMapping_Base.cpphs" 1
module WinDll.Lib.NativeMapping_Debug where
import FastString
import FastTypes
import Foreign.C
import Foreign.C.String
import Foreign hiding (free, malloc, alloca, realloc)
import Foreign.Marshal.Alloc hiding (free, malloc, alloca, realloc)
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 WinDll.Debug.Stack
import WinDll.Debug.Alloc
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
toFFI :: Stackable st => st -> phi -> ix
toFFI st = error $ show st ++ ": toFFI is undefined for the specified type, try toNative instead."
fromFFI :: Stackable st => st -> ix -> phi
fromFFI st = error $ show st ++ ": fromFFI is undefined for the specified type, try fromNative instead."
fromList :: Stackable st => st -> CInt -> ix -> IO phi
fromList st = error $ show st ++ ": fromList is undefined for this type. "
++ "Please add a definition or consider using one of the default ones."
fromNative :: Stackable st => st -> ix -> IO phi
fromNative st = return.fromFFI st
toNative :: Stackable st => st -> phi -> IO ix
toNative st = return.toFFI st
freeFFI :: Stackable st => st -> phi -> ix -> IO ()
freeFFI = \_ _ _ -> return ();
# 129 "WinDll/Lib/NativeMapping_Base.cpphs"
# 173 "WinDll/Lib/NativeMapping_Base.cpphs"
instance FFIType () () where
toFFI = const id
fromFFI = const id
instance FFIType Bool Bool where
toFFI = const id
fromFFI = const id
instance FFIType Bool CInt where
toFFI = const (\x-> case x of
False -> 0
True -> 1)
fromFFI = const (\x-> case x of
0 -> False
1 -> True)
instance FFIType Bool Word8 where
toFFI = const (\x-> case x of
False -> 0
True -> 1)
fromFFI = const (\x-> case x of
0 -> False
1 -> True)
instance FFIType Bool Int8 where
toFFI = const (\x-> case x of
False -> 0
True -> 1)
fromFFI = const (\x-> case x of
0 -> False
1 -> True)
instance FFIType (StablePtr a) (StablePtr a) where
toFFI = const id
fromFFI = const id
freeFFI _ = const freeStablePtr
instance FFIType (FunPtr a) (FunPtr a) where
toFFI = const id
fromFFI = const id
freeFFI _ = const freeHaskellFunPtr
instance (FFIType a b, FFIType c d) => FFIType (a -> c) (b -> d) where
toFFI st f x = toFFI st (f (fromFFI st x))
fromFFI st f x = fromFFI st (f (toFFI st x))
instance FFIType String CWString where
toNative = \st val -> recordM (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 241) ++ "(" ++ "newCWString" ++ ")")) val newCWString
fromNative st ptr = (\st ptr -> record (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 242) ++ "(" ++ "peekCWString" ++ ")")) ptr >> return ( id ptr)) st ptr
>> peekCWString ptr
>>= \str -> freeFFI st "" ptr
>> return str
freeFFI = \st _ ptr -> freeDefault (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 246) ++ "(" ++ "freeCWString" ++ ")")) ptr F.free
instance (Storable a, FFIType b a) => FFIType [b] (Ptr a) where
toNative st = (\st val -> recordM (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 250) ++ "(" ++ "newArray" ++ ")")) val newArray) st . map (toFFI st)
fromList st x = fmap (map (fromFFI st)) . (\st ptr -> record (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 251) ++ "(" ++ "peekArray" ++ ")")) ptr >> return ( id ptr) >>= peekArray (fromFFI st x)) st
instance FFIType CWchar CWchar where
fromFFI = const id
toFFI = const id
instance FFIType CWString CWString where
fromFFI = const id
toFFI = const id
instance FFIType CInt CInt where
toFFI = const id
fromFFI = const id
instance FFIType CDouble CDouble where
toFFI = const id
fromFFI = const id
instance FFIType CLLong CLLong where
toFFI = const id
fromFFI = const id
instance FFIType FastString CWString where
toFFI st = toFFI st.unpackFS
fromFFI st = mkFastString.fromFFI st
instance FFIType Int CInt where
toFFI = const fromIntegral
fromFFI = const fromIntegral
instance FFIType Float CFloat where
toFFI = const realToFrac
fromFFI = const realToFrac
instance Storable a => FFIType a (Ptr a) where
toNative = \st val -> recordM (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 305) ++ "(" ++ "new" ++ ")")) val new
fromNative = \st ptr -> record (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 306) ++ "(" ++ "peek" ++ ")")) ptr >> return ( id ptr) >>= peek
freeFFI = \st _ ptr -> freeDefault (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 307) ++ "(" ++ "free" ++ ")")) ptr F.free
instance Storable a => FFIType [a] (Ptr a) where
toNative = \st val -> recordM (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 311) ++ "(" ++ "newArray" ++ ")")) val newArray
fromList st ic ptr = (\st ptr -> record (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 313) ++ "(" ++ "peek" ++ ")")) ptr >> return ( id ptr)) st ptr >> peekArray (fromFFI st ic) ptr
freeFFI = \st _ ptr -> freeDefault (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 317) ++ "(" ++ "freeArray" ++ ")")) ptr F.free
instance (FFIType a b, Storable b) => FFIType [a] (Ptr CInt -> IO (Ptr b)) where
toNative st lst = let ln = length lst
in return $ \t -> do ln' <- toNative st ln
poke t ln'
toNative st lst
fromNative st fn = do ptr <- (\st -> malloc (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 329) ++ "(" ++ "malloc" ++ ")"))) st
lst <- fn ptr
ln <- peek ptr
val <- fromList st ln lst
(\st _ ptr -> freeDefault (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 333) ++ "(" ++ "freePtr" ++ ")")) ptr F.free) st undefined ptr
(\st _ ptr -> freeDefault (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 334) ++ "(" ++ "freeLst" ++ ")")) ptr F.free) st undefined lst
return $ val
# 349 "WinDll/Lib/NativeMapping_Base.cpphs"
instance Storable a => Storable [a] where
sizeOf _ = 4
alignment _ = 4
poke ptr value = do newptr <- (\st val -> recordM (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 356) ++ "(" ++ "newArray" ++ ")")) val newArray) emptyStack value
copyArray (castPtr ptr) newptr (length value)
peekElemOff ptr c = do val <- peekArray c (castPtr ptr)
(\st _ ptr -> freeDefault (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 363) ++ "(" ++ "freeArray" ++ ")")) ptr F.free) emptyStack undefined ptr
return val
instance (Num a,Integral a) => FFIType Integer a where
toFFI = const fromInteger
fromFFI = const toInteger
instance (Functor f, FFIType a b) => FFIType (f a) (f b) where
toFFI st = fmap (toFFI st)
fromFFI st = fmap (fromFFI st)
instance FFIType Char CChar where
toFFI = const castCharToCChar
fromFFI = const castCCharToChar
instance FFIType Rational CDouble where
toFFI = const fromRational
fromFFI = const toRational
instance FFIType Char CWchar where
toFFI = const (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 = const (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_Debug.cpphs" 2