# 1 "WinDll/Lib/NativeMapping_Debug.cpphs"
# 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 ();
# 131 "WinDll/Lib/NativeMapping_Base.cpphs"
# 175 "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
newtype Pure a = Pure{ pure :: a }
deriving Functor
instance FFIType (Pure Int) (Pure CInt) where
toFFI st = fmap (toFFI st)
fromFFI st = fmap (fromFFI st)
instance FFIType (Pure Float) (Pure CFloat) where
toFFI st = fmap (toFFI st)
fromFFI st = fmap (fromFFI st)
instance (Num a,Integral a) => FFIType (Pure Integer) (Pure a) where
toFFI st = fmap (toFFI st)
fromFFI st = fmap (fromFFI st)
instance FFIType (Pure Char) (Pure CChar) where
toFFI st = fmap (toFFI st)
fromFFI st = fmap (fromFFI st)
instance FFIType (Pure Rational) (Pure CDouble) where
toFFI st = fmap (toFFI st)
fromFFI st = fmap (fromFFI st)
instance FFIType (Pure Char) (Pure CWchar) where
toFFI st = fmap (toFFI st)
fromFFI st = fmap (fromFFI st)
instance FFIType a b => FFIType (Pure [a]) (Pure [b]) where
toFFI st = fmap (fmap (toFFI st))
fromFFI st = fmap (fmap (fromFFI st))
instance ( FFIType (Pure a) (Pure b)
, FFIType (Pure c) (Pure d)
, FFIType c d
, FFIType a b)
=> FFIType (Pure (a -> c)) (Pure (b -> d)) where
toFFI st f = Pure $ to (pure f)
where to f x = toFFI st (f (fromFFI st x))
fromFFI st f = Pure $ from (pure f)
where from 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 293) ++ "(" ++ "newCWString" ++ ")")) val newCWString
fromNative st ptr = do {(\st ptr -> record (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 294) ++ "(" ++ "peekCWString" ++ ")")) ptr >> return ( id ptr)) st ptr;
str <- peekCWString ptr;
return str;}
freeFFI = \st _ ptr -> freeDefault (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 299) ++ "(" ++ "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 303) ++ "(" ++ "newArray" ++ ")")) val (\val -> newArray =<< mapM (toNative st $!) val)) st
fromList st x ptr = do {(\st ptr -> record (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 304) ++ "(" ++ "peekArray" ++ ")")) ptr >> return ( id ptr)) st ptr;
i <- fromNative st x;
v <- peekArray i ptr;
mapM (fromNative st) v;}
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
toNative st = toNative st . unpackFS
fromNative st = (mkFastString `fmap`) . fromNative 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 361) ++ "(" ++ "new" ++ ")")) val new
fromNative = \st ptr -> record (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 362) ++ "(" ++ "peek" ++ ")")) ptr >> return ( id ptr) >>= peek
freeFFI = \st _ ptr -> freeDefault (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 363) ++ "(" ++ "free" ++ ")")) ptr F.free
instance Storable a => FFIType [a] (Ptr a) where
toNative = \st val -> recordM (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 367) ++ "(" ++ "newArray" ++ ")")) val newArray
fromList st ic ptr = (\st ptr -> record (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 369) ++ "(" ++ "peek" ++ ")")) ptr >> return ( id ptr)) st ptr >> fromNative st ic >>= \i -> peekArray i ptr
freeFFI = \st _ ptr -> freeDefault (pushStack st ( "WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 373) ++ "(" ++ "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 385) ++ "(" ++ "malloc" ++ ")"))) st
lst <- fn ptr
ln <- peek ptr
val <- fromList st ln lst
(\st _ ptr -> freeDefault (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 389) ++ "(" ++ "freePtr" ++ ")")) ptr F.free) st undefined ptr
(\st _ ptr -> freeDefault (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 390) ++ "(" ++ "freeLst" ++ ")")) ptr F.free) st undefined lst
return $ val
# 405 "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 412) ++ "(" ++ "newArray" ++ ")")) val newArray) emptyStack value
copyArray (castPtr ptr) newptr (length value)
(\st _ ptr -> freeDefault (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 418) ++ "(" ++ "freeArray" ++ ")")) ptr F.free) emptyStack undefined ptr
peekElemOff ptr c = do val <- peekArray c (castPtr ptr)
(\st _ ptr -> freeDefault (pushStack st ("WinDll/Lib/NativeMapping_Base.cpphs" ++ ":" ++ (show 425) ++ "(" ++ "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 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