Hs2lib 0.4.8 → 0.5.0
raw patch · 66 files changed
+3668/−2847 lines, 66 filesdep +haskell98dep ~filepathbuild-type:Customsetup-changednew-component:exe:Hs2lib-debugbinary-addedPVP ok
version bump matches the API change (PVP)
Dependencies added: haskell98
Dependency ranges changed: filepath
API changes (from Hackage documentation)
+ WinDll.Debug.Alloc: alloca :: (Storable a, Stackable st) => st -> (Ptr a -> IO b) -> IO b
+ WinDll.Debug.Alloc: free :: (Storable a, Stackable st) => st -> Ptr a -> IO ()
+ WinDll.Debug.Alloc: freeDefault :: (Storable a, Stackable st, Show (m a)) => st -> m a -> (m a -> IO ()) -> IO ()
+ WinDll.Debug.Alloc: freeUnknown :: (Stackable st, Show (m a)) => st -> m a -> (m a -> IO ()) -> IO ()
+ WinDll.Debug.Alloc: malloc :: (Storable a, Stackable st) => st -> IO (Ptr a)
+ WinDll.Debug.Alloc: realloc :: (Storable b, Stackable st) => st -> Ptr a -> IO (Ptr b)
+ WinDll.Debug.Alloc: record :: (Storable a, Stackable st, Show (m a)) => st -> m a -> IO ()
+ WinDll.Debug.Alloc: recordM :: (Storable a, Stackable st) => st -> b -> (b -> IO (Ptr a)) -> IO (Ptr a)
+ WinDll.Debug.Exports: freeC :: Ptr () -> IO ()
+ WinDll.Debug.Exports: freeS :: Ptr () -> IO ()
+ WinDll.Debug.Records: Alloc :: Caller
+ WinDll.Debug.Records: Malloc :: Caller
+ WinDll.Debug.Records: MemAlloc :: Caller -> Stack -> PtrLocation -> Maybe PtrLocation -> Maybe MemSize -> String -> MemAlloc
+ WinDll.Debug.Records: MemFree :: Stack -> PtrLocation -> Maybe MemSize -> String -> MemAlloc
+ WinDll.Debug.Records: Other :: Caller
+ WinDll.Debug.Records: ReAlloc :: Caller
+ WinDll.Debug.Records: Record :: Caller
+ WinDll.Debug.Records: data Caller
+ WinDll.Debug.Records: data MemAlloc
+ WinDll.Debug.Records: fileName :: IO String
+ WinDll.Debug.Records: instance Read Caller
+ WinDll.Debug.Records: instance Read MemAlloc
+ WinDll.Debug.Records: instance Show Caller
+ WinDll.Debug.Records: instance Show MemAlloc
+ WinDll.Debug.Records: memFun :: MemAlloc -> Caller
+ WinDll.Debug.Records: memSize :: MemAlloc -> Maybe MemSize
+ WinDll.Debug.Records: memStack :: MemAlloc -> Stack
+ WinDll.Debug.Records: memStart :: MemAlloc -> PtrLocation
+ WinDll.Debug.Records: memStop :: MemAlloc -> Maybe PtrLocation
+ WinDll.Debug.Records: memTime :: MemAlloc -> String
+ WinDll.Debug.Records: writeMemAlloc :: MemAlloc -> IO ()
+ WinDll.Debug.Stack: class Show a => Stackable a
+ WinDll.Debug.Stack: data Stack
+ WinDll.Debug.Stack: emptyStack :: Stack
+ WinDll.Debug.Stack: instance Data Stack
+ WinDll.Debug.Stack: instance Eq Stack
+ WinDll.Debug.Stack: instance Ord Stack
+ WinDll.Debug.Stack: instance Read Stack
+ WinDll.Debug.Stack: instance Show Stack
+ WinDll.Debug.Stack: instance Stackable Stack
+ WinDll.Debug.Stack: instance Stackable String
+ WinDll.Debug.Stack: instance Typeable Stack
+ WinDll.Debug.Stack: newStack :: FunctionName -> Stack
+ WinDll.Debug.Stack: popStack :: Stack -> Stack
+ WinDll.Debug.Stack: printStack :: Stack -> String
+ WinDll.Debug.Stack: pushStack :: Stackable st => st -> FunctionName -> Stack
+ WinDll.Debug.Stack: shrinkStack :: Stack -> Stack
+ WinDll.Debug.Stack: sizeStack :: Stack -> Int
+ WinDll.Debug.Stack: toStack :: Stackable a => a -> Stack
+ WinDll.Debug.Stack: topStack :: Stack -> Maybe FunctionName
+ WinDll.Debug.Stack: type FunctionName = String
+ WinDll.Lib.NativeMapping_Debug: class FFIType phi ix
+ WinDll.Lib.NativeMapping_Debug: class LLD m a b c | b -> c
+ WinDll.Lib.NativeMapping_Debug: freeFFI :: (FFIType phi ix, Stackable st) => st -> phi -> ix -> IO ()
+ WinDll.Lib.NativeMapping_Debug: fromFFI :: (FFIType phi ix, Stackable st) => st -> ix -> phi
+ WinDll.Lib.NativeMapping_Debug: fromList :: (FFIType phi ix, Stackable st) => st -> CInt -> ix -> IO phi
+ WinDll.Lib.NativeMapping_Debug: fromNative :: (FFIType phi ix, Stackable st) => st -> ix -> IO phi
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] (FFIType a b, FFIType c d) => FFIType (a -> c) (b -> d)
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] (FFIType a b, Storable b) => FFIType [a] (Ptr CInt -> IO (Ptr b))
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] (Functor f, FFIType a b) => FFIType (f a) (f b)
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] (Num a, Integral a) => FFIType Integer a
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] (Storable a, FFIType b a) => FFIType [b] (Ptr a)
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType () ()
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType (FunPtr a) (FunPtr a)
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType (StablePtr a) (StablePtr a)
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType Bool Bool
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType Bool CInt
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType Bool Int8
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType Bool Word8
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType CDouble CDouble
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType CInt CInt
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType CLLong CLLong
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType CWString CWString
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType CWchar CWchar
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType Char CChar
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType Char CWchar
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType FastString CWString
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType Float CFloat
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType Int CInt
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType Rational CDouble
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] FFIType String CWString
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] LLD (->) a b (IO b)
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] Storable a => FFIType [a] (Ptr a)
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] Storable a => FFIType a (Ptr a)
+ WinDll.Lib.NativeMapping_Debug: instance [incoherent] Storable a => Storable [a]
+ WinDll.Lib.NativeMapping_Debug: isSimpleType :: Type -> Bool
+ WinDll.Lib.NativeMapping_Debug: lld :: LLD m a b c => m a b -> m a c
+ WinDll.Lib.NativeMapping_Debug: split :: Eq a => [a] -> a -> [[a]]
+ WinDll.Lib.NativeMapping_Debug: toFFI :: (FFIType phi ix, Stackable st) => st -> phi -> ix
+ WinDll.Lib.NativeMapping_Debug: toNative :: (FFIType phi ix, Stackable st) => st -> phi -> IO ix
+ WinDll.Lib.NativeMapping_Debug: translate :: Defs -> Type -> Type
+ WinDll.Lib.NativeMapping_Debug: translate' :: Defs -> String -> String
+ WinDll.Lib.NativeMapping_Debug: translateP :: Defs -> String -> String
+ WinDll.Lib.NativeMapping_Debug: translatePForm :: Defs -> Type -> Type
+ WinDll.Lib.NativeMapping_Debug: translatePartial :: Defs -> Type -> Type
+ WinDll.Lib.NativeMapping_Debug: translatePrimitive :: Defs -> Type -> Type
+ WinDll.Lib.NativeMapping_Debug: trim :: String -> String
+ WinDll.Lib.Tuples_Debug: Tuple2 :: a -> b -> Tuple2 a b
+ WinDll.Lib.Tuples_Debug: Tuple3 :: a -> b -> c -> Tuple3 a b c
+ WinDll.Lib.Tuples_Debug: Tuple4 :: a -> b -> c -> d -> Tuple4 a b c d
+ WinDll.Lib.Tuples_Debug: Tuple5 :: a -> b -> c -> d -> e -> Tuple5 a b c d e
+ WinDll.Lib.Tuples_Debug: Tuple6 :: a -> b -> c -> d -> e -> f -> Tuple6 a b c d e f
+ WinDll.Lib.Tuples_Debug: Tuple7 :: a -> b -> c -> d -> e -> f -> g -> Tuple7 a b c d e f g
+ WinDll.Lib.Tuples_Debug: Tuple8 :: a -> b -> c -> d -> e -> f -> g -> h -> Tuple8 a b c d e f g h
+ WinDll.Lib.Tuples_Debug: data Tuple2 a b
+ WinDll.Lib.Tuples_Debug: data Tuple3 a b c
+ WinDll.Lib.Tuples_Debug: data Tuple4 a b c d
+ WinDll.Lib.Tuples_Debug: data Tuple5 a b c d e
+ WinDll.Lib.Tuples_Debug: data Tuple6 a b c d e f
+ WinDll.Lib.Tuples_Debug: data Tuple7 a b c d e f g
+ WinDll.Lib.Tuples_Debug: data Tuple8 a b c d e f g h
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d) => FFIType (a, c) (Tuple2 b d)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f) => FFIType (a, c, e) (Tuple3 b d f)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f, FFIType g h) => FFIType (a, c, e, g) (Tuple4 b d f h)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f, FFIType g h, FFIType i j) => FFIType (a, c, e, g, i) (Tuple5 b d f h j)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f, FFIType g h, FFIType i j, FFIType k l) => FFIType (a, c, e, g, i, k) (Tuple6 b d f h j l)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f, FFIType g h, FFIType i j, FFIType k l, FFIType m n) => FFIType (a, c, e, g, i, k, m) (Tuple7 b d f h j l n)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f, FFIType g h, FFIType i j, FFIType k l, FFIType m n, FFIType o p) => FFIType (a, c, e, g, i, k, m, o) (Tuple8 b d f h j l n p)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f, FFIType g h, FFIType i j, FFIType k l, FFIType m n, FFIType o p, Storable n, Storable p, Storable j, Storable l, Storable b, Storable d, Storable f, Storable h) => FFIType (a, c, e, g, i, k, m, o) (Tuple8Ptr b d f h j l n p)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f, FFIType g h, FFIType i j, FFIType k l, FFIType m n, Storable n, Storable j, Storable l, Storable b, Storable d, Storable f, Storable h) => FFIType (a, c, e, g, i, k, m) (Tuple7Ptr b d f h j l n)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f, FFIType g h, FFIType i j, FFIType k l, Storable j, Storable l, Storable b, Storable d, Storable f, Storable h) => FFIType (a, c, e, g, i, k) (Tuple6Ptr b d f h j l)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f, FFIType g h, FFIType i j, Storable j, Storable b, Storable d, Storable f, Storable h) => FFIType (a, c, e, g, i) (Tuple5Ptr b d f h j)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f, FFIType g h, Storable b, Storable d, Storable f, Storable h) => FFIType (a, c, e, g) (Tuple4Ptr b d f h)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, FFIType e f, Storable b, Storable d, Storable f) => FFIType (a, c, e) (Tuple3Ptr b d f)
+ WinDll.Lib.Tuples_Debug: instance (FFIType a b, FFIType c d, Storable b, Storable d) => FFIType (a, c) (Tuple2Ptr b d)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b) => Storable (Tuple2 a b)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b) => Storable (a, b)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c) => Storable (Tuple3 a b c)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c) => Storable (a, b, c)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c, Storable d) => Storable (Tuple4 a b c d)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c, Storable d) => Storable (a, b, c, d)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c, Storable d, Storable e) => Storable (Tuple5 a b c d e)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c, Storable d, Storable e) => Storable (a, b, c, d, e)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f) => Storable (Tuple6 a b c d e f)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f) => Storable (a, b, c, d, e, f)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => Storable (Tuple7 a b c d e f g)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => Storable (a, b, c, d, e, f, g)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g, Storable h) => Storable (Tuple8 a b c d e f g h)
+ WinDll.Lib.Tuples_Debug: instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g, Storable h) => Storable (a, b, c, d, e, f, g, h)
+ WinDll.Lib.Tuples_Debug: instance Storable a => Functor (Tuple2 a)
+ WinDll.Lib.Tuples_Debug: instance Storable a => Functor (Tuple3 a b)
+ WinDll.Lib.Tuples_Debug: instance Storable a => Functor (Tuple4 a b c)
+ WinDll.Lib.Tuples_Debug: instance Storable a => Functor (Tuple5 a b c d)
+ WinDll.Lib.Tuples_Debug: instance Storable a => Functor (Tuple6 a b c d e)
+ WinDll.Lib.Tuples_Debug: instance Storable a => Functor (Tuple7 a b c d e f)
+ WinDll.Lib.Tuples_Debug: instance Storable a => Functor (Tuple8 a b c d e f g)
+ WinDll.Lib.Tuples_Debug: type Tuple2Ptr a b = Ptr (Tuple2 a b)
+ WinDll.Lib.Tuples_Debug: type Tuple3Ptr a b c = Ptr (Tuple3 a b c)
+ WinDll.Lib.Tuples_Debug: type Tuple4Ptr a b c d = Ptr (Tuple4 a b c d)
+ WinDll.Lib.Tuples_Debug: type Tuple5Ptr a b c d e = Ptr (Tuple5 a b c d e)
+ WinDll.Lib.Tuples_Debug: type Tuple6Ptr a b c d e f = Ptr (Tuple6 a b c d e f)
+ WinDll.Lib.Tuples_Debug: type Tuple7Ptr a b c d e f g = Ptr (Tuple7 a b c d e f g)
+ WinDll.Lib.Tuples_Debug: type Tuple8Ptr a b c d e f g h = Ptr (Tuple8 a b c d e f g h)
+ WinDll.Structs.Types: annDebug :: Ann -> Bool
+ WinDll.Structs.Types: annModule :: Ann -> ModuleName
+ WinDll.Structs.Types: antModule :: AnnType -> ModuleName
+ WinDll.Structs.Types: type ModuleName = String
- WinDll.Structs.Types: Ann :: [Int] -> Bool -> [Int] -> [(String, String)] -> [(String, String)] -> [(String, Int)] -> (Bool -> [(String, String)]) -> Ann
+ WinDll.Structs.Types: Ann :: [Int] -> Bool -> [Int] -> [(String, String)] -> [(String, String)] -> [(String, Int)] -> (Bool -> [(String, String)]) -> Bool -> ModuleName -> Ann
- WinDll.Structs.Types: AnnType :: Name -> Type -> Ann -> Type -> AnnType
+ WinDll.Structs.Types: AnnType :: Name -> Type -> Ann -> Type -> ModuleName -> AnnType
Files
- Hs2lib-debug.hs +58/−0
- Hs2lib.cabal +79/−10
- Hs2lib.hs +3/−3
- Includes/FFI/Key.snk binary
- LIMITS.TXT +0/−25
- LIMITS.txt +34/−0
- ListTest.hs +0/−39
- Setup.lhs +60/−1
- Tests/Test-Regression-Debug.hs +21/−0
- Tests/Test-Regression.hs +21/−0
- Tests/TestRunner.hs +20/−24
- WinDll/Builder.hs +3/−3
- WinDll/CmdArgs.hs +0/−176
- WinDll/CmdArgs/Debug.hs +120/−0
- WinDll/CmdArgs/Hs2lib.hs +183/−0
- WinDll/CodeGen/C.hs +27/−17
- WinDll/CodeGen/CSharp/CSharp.hs +25/−15
- WinDll/CodeGen/Haskell.hs +35/−28
- WinDll/CodeGen/Lookup.hs +1/−1
- WinDll/Debug/Alloc.xhs +138/−0
- WinDll/Debug/Analyzer.hs +39/−0
- WinDll/Debug/Exports.xhs +33/−0
- WinDll/Debug/Heap.hs +132/−0
- WinDll/Debug/Heap.hs-boot +15/−0
- WinDll/Debug/Output.hs +96/−0
- WinDll/Debug/Records.xhs +79/−0
- WinDll/Debug/Stack.xhs +102/−0
- WinDll/EntryPoint.hs +1/−1
- WinDll/Identifier.hs +32/−26
- WinDll/Lib/Instances.hs +6/−7
- WinDll/Lib/NativeMapping.cpphs +3/−0
- WinDll/Lib/NativeMapping.hs +0/−384
- WinDll/Lib/NativeMapping_Base.cpphs +487/−0
- WinDll/Lib/NativeMapping_Debug.cpphs +3/−0
- WinDll/Lib/Tuples.hs +0/−637
- WinDll/Lib/Tuples.hsc +0/−464
- WinDll/Lib/Tuples.xpphs +3/−0
- WinDll/Lib/Tuples_Base.cpphs +508/−0
- WinDll/Lib/Tuples_Debug.xpphs +3/−0
- WinDll/Parsers.hs +0/−566
- WinDll/Parsers/Debug.hs +20/−0
- WinDll/Parsers/Hs2lib.hs +585/−0
- WinDll/Session.hs +0/−248
- WinDll/Session/Debug.hs +123/−0
- WinDll/Session/Hs2lib.hs +253/−0
- WinDll/Structs/C.hs +1/−1
- WinDll/Structs/CSharp.hs +1/−1
- WinDll/Structs/Folds/C.hs +1/−1
- WinDll/Structs/Folds/CSharp.hs +1/−1
- WinDll/Structs/Folds/Haskell.hs +15/−15
- WinDll/Structs/Haskell.hs +20/−19
- WinDll/Structs/MShow/C.hs +1/−1
- WinDll/Structs/MShow/CSharp.hs +4/−3
- WinDll/Structs/MShow/Haskell.hs +97/−53
- WinDll/Structs/MShow/MShow.hs +4/−4
- WinDll/Structs/PrettyPrinting.hs +11/−10
- WinDll/Structs/Structures.hs +11/−5
- WinDll/Structs/Types.hs +15/−6
- WinDll/Utils/DepScanner.hs +1/−1
- WinDll/Utils/Feedback.hs +38/−3
- WinDll/Utils/HaddockRead.hs +5/−2
- WinDll/Utils/Pragma.hs +1/−1
- WinDll/Utils/Processes.hs +2/−1
- WinDll/Version.hs +0/−44
- WinDll/Version/Debug.hs +44/−0
- WinDll/Version/Hs2lib.hs +44/−0
+ Hs2lib-debug.hs view
@@ -0,0 +1,58 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : GPL +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- The main entry file for the preprocessor +-- part of the WinDll suite +-- +----------------------------------------------------------------------------- + +module Main where + +import WinDll.CmdArgs.Debug +import WinDll.Session.Debug +import WinDll.Parsers.Debug +import WinDll.Debug.Output +import WinDll.Utils.Feedback + +import System.Info +import Control.Monad.State.Strict +import Control.Monad.Error + +-- | Determine the platform we're currently running on, so we can tweak the defaults a bit +mode :: Platform +mode = case os of + "mingw32" -> Windows + _ -> Unix + +main = goArgs mode bootstrap + +-- | Get the ball rolling on everything +bootstrap :: Config -> IO () +bootstrap cfg = + do val <- runErrorT (evalStateT mainStart cfg) + case val of + (Left str) -> fail ("Program returned error in computation: '" ++ str ++ "'") + (Right _) -> return () + +-- | Start of the main computation +mainStart :: Exec () +mainStart = do inform _normal "Program starting up..." + discoverFiles + loadAndParse + + -- These lines do all the needed calculations + result <- analyze + displayResults result + + -- clean up + cleanup + + inform _detail "Program terminating..." + liftIO $ putStrLn "Done."
Hs2lib.cabal view
@@ -1,7 +1,7 @@ Name: Hs2lib -Version: 0.4.8 +Version: 0.5.0 Cabal-Version: >= 1.10 -Build-Type: Simple +Build-Type: Custom License: BSD3 License-File: LICENSE.txt Author: Tamar Christina <tamar@zhox.com> @@ -10,7 +10,7 @@ Category: Development Stability: experimental Synopsis: A Library and Preprocessor that makes it easier to create shared libs from Haskell programs. -Description: The supplied PreProcessor can be run over any existing source and would generate FFI code for every function marked to be exported by the special notation documented inside the package. It then proceeds to compile this generated code into a windows DLL. +Description: The supplied PreProcessor can be run over any existing source and would generate FFI code for every function marked to be exported by the special notation documented inside the package. It then proceeds to compile this generated code into a lib. . The Library contains some helper code that's commonly needed to convert between types, and contains the code for the typeclasses the PreProcessor uses in the generated code to keep things clean. . @@ -53,9 +53,14 @@ WinDll/CodeGen/*.hs, WinDll/CodeGen/CSharp/*.hs, WinDll/COFF/*.hs, - WinDll/Lib/*.hsc, + -- WinDll/Lib/*.hsc, + WinDll/Lib/*.cpphs, + WinDll/Lib/*.xpphs, WinDll/Lib/*.hs, WinDll/Shared/*.hs, + WinDll/Debug/*.hs, + WinDll/Debug/*.xhs, + WinDll/Debug/*.hs-boot, WinDll/Structs/*.hs, WinDll/Structs/Folds/*.hs, WinDll/Structs/MShow/*.hs, @@ -74,16 +79,26 @@ Exposed: True Exposed-Modules: WinDll.Lib.Converter, WinDll.Lib.NativeMapping, + WinDll.Lib.InstancesTypes, + WinDll.Debug.Alloc, + WinDll.Debug.Records, + WinDll.Debug.Stack, + WinDll.Debug.Exports, + WinDll.Lib.NativeMapping_Debug, WinDll.Lib.Native, WinDll.Lib.Tuples, - WinDll.Structs.Types, - WinDll.Lib.InstancesTypes + WinDll.Lib.Tuples_Debug, + WinDll.Structs.Types Build-Depends: haskell-src-exts >= 1.9.0, ghc >= 6.12 && < 7.0 || >= 7.0.2, base >= 4 && < 5, filepath >= 1 && < 1.3, - syb >= 0.1.0.2 + old-locale >= 1.0.0.2, + time >= 1.2.0.3, + directory >= 1.0.0.3, + syb >= 0.1.0.2, + random >= 1.0.0.1 Other-Modules: Paths_Hs2lib Default-Language: Haskell98 @@ -91,7 +106,7 @@ if !os(windows) GHC-Options: -fPIC - Build-Tools: hsc2hs + Build-Tools: hsc2hs, cpphs Include-Dirs: Includes @@ -117,6 +132,60 @@ cereal >= 0.3.0.0 ghc-options: -threaded -fspec-constr-count=16 + cpp-options: -UDEBUG - Other-Modules: Paths_Hs2lib - Default-Language: Haskell98+ Other-Modules: Paths_Hs2lib, + WinDll.Lib.NativeMapping, + WinDll.Lib.NativeMapping_Debug + + Default-Language: Haskell98 + +Executable Hs2lib-debug + Main-is: Hs2lib-debug.hs + + Build-Depends: QuickCheck >= 2.1.0.1, + directory >= 1.0.0.3, + ghc-paths >= 0.1.0.5, + filepath >= 1.1.0.2, + random >= 1.0.0.1, + process >= 1.0.1.1, + ghc >= 6.12 && < 7.0 || >= 7.0.2, + mtl >= 1.1.0.2, + containers >= 0.2.0.0, + array >= 0.2.0.0, + haskell-src-exts >= 1.9.0, + haddock >= 2.7.2, + base >= 4 && < 5, + syb >= 0.1.0.2, + time >= 1.2.0.3, + old-locale >= 1.0.0.2, + cereal >= 0.3.0.0 + + ghc-options: -threaded -fspec-constr-count=16 -rtsopts + cpp-options: -DDEBUG + + Other-Modules: Paths_Hs2lib, + WinDll.Lib.NativeMapping, + WinDll.Lib.NativeMapping_Debug, + WinDll.Debug.Records, + WinDll.Debug.Stack + + Default-Language: Haskell98 + +Test-Suite test-regression + type: exitcode-stdio-1.0 + main-is: Tests\Test-Regression.hs + Default-Language: Haskell98 + build-depends: base >= 4 && < 5, + filepath >= 1.1.0.2, + process >= 1.0.1.1, + haskell98 >= 1.1.0.1 + +Test-Suite test-regression-debug + type: exitcode-stdio-1.0 + main-is: Tests\Test-Regression-Debug.hs + Default-Language: Haskell98 + build-depends: base >= 4 && < 5, + filepath >= 1.1.0.2, + process >= 1.0.1.1, + haskell98 >= 1.1.0.1
Hs2lib.hs view
@@ -15,11 +15,11 @@ module Main where -import WinDll.CmdArgs -import WinDll.Session +import WinDll.CmdArgs.Hs2lib +import WinDll.Session.Hs2lib import WinDll.Utils.Feedback import WinDll.Utils.DepScanner hiding (main) -import WinDll.Parsers +import WinDll.Parsers.Hs2lib import WinDll.EntryPoint import WinDll.Identifier import WinDll.Builder
+ Includes/FFI/Key.snk view
binary file changed (absent → 596 bytes)
− LIMITS.TXT
@@ -1,25 +0,0 @@-Version 0.4.8 - - Major restructuring of code to allow users to extend/override - the default type conversions of the tool. - - Support for custom type translations - -Version 0.4.5 - - Brand new Haskell code generators - - Support for lists inside an IO wrapper (e.g. IO [Int]) - - Brand new implementation in NativeMapping - - Avoids unsafePerformIO as much as possible - -Version 0.4.4 - - Fixed Include paths - - NO support for datastructures with multiple constructors where - one constructor has the same name as the datatype - (codegen naming limitation) - - Fixed codegen issue with callbacks - - Added better IO Error handling - -Version 0.4.3 (Initial Release) - - NO support for infix constructors - - NO support for lists inside Applied types (e.g. Maybe [String]) - - NO support for lists inside tuples (e.g. (Int, [String])) - - Does not allow for custom translation of types. - - NO support for quantified types. (e.g. M.Map)
+ LIMITS.txt view
@@ -0,0 +1,34 @@+Version 0.5.0 + - Added support for memory leak tracing with the --debug flag + % Added support for qualified importing. It is now possible to export + values and types with the same name. + % - Added the ability to export polymorphic types. + % - Added support for infix constructors + + Does not support the ability to silence the generation of a free function + for a particular StablePtr + +Version 0.4.8 + - Major restructuring of code to allow users to extend/override + the default type conversions of the tool. + - Support for custom type translations + +Version 0.4.5 + - Brand new Haskell code generators + - Support for lists inside an IO wrapper (e.g. IO [Int]) + - Brand new implementation in NativeMapping + - Avoids unsafePerformIO as much as possible + +Version 0.4.4 + - Fixed Include paths + - NO support for datastructures with multiple constructors where + one constructor has the same name as the datatype + (codegen naming limitation) + - Fixed codegen issue with callbacks + - Added better IO Error handling + +Version 0.4.3 (Initial Release) + - NO support for infix constructors + - NO support for lists inside Applied types (e.g. Maybe [String]) + - NO support for lists inside tuples (e.g. (Int, [String])) + - Does not allow for custom translation of types. + - NO support for quantified types. (e.g. M.Map)
− ListTest.hs
@@ -1,39 +0,0 @@-{- @@ IMPORT "Data.IORef" "Foreign.StablePtr" @@ -} -module ListTest where - -import Data.Char ( chr ) - -data Single = Single { sint :: Int - , schar :: Char - } - -data Multi = Demi { mints :: [Int] - , mstring :: String -- avoid [Char] - } - | Semi { semi :: [Single] - } - -newtype SiMu = SiMu { semu :: Single -> Multi } - --- @@ Export --- | Create a Single payload -mkSingle :: Int -> Single -mkSingle x = Single x (chr x) - --- @@ Export --- | Maybe create a Single payload --- to illustrate specialization -mkMaybeSingle :: Int -> Maybe Single -mkMaybeSingle x | x >= 97 && x <= 122 = return (mkSingle x) -mkMaybeSingle _ = Nothing - --- @@ Export --- | Creating a Multi datatype from --- a single datatype via callback -mkSingleCallback :: Int -> (Single -> Multi) -> Multi -mkSingleCallback x f = f (mkSingle x) - --- @@ Export --- | Same as mkSingleCallback but with a SiMu -mkSiMu :: SiMu -mkSiMu = SiMu { semu = \x -> Semi [x] }
Setup.lhs view
@@ -1,6 +1,65 @@ #!/usr/bin/env runhaskell+> {-# LANGUAGE BangPatterns #-} > import Distribution.Simple+> import Distribution.Simple.PreProcess+> import Distribution.Simple.Utils > import qualified Tests.TestRunner as TR+> import Distribution.PackageDescription+> import Distribution.Simple.LocalBuildInfo+> import Data.Char+> import System.Exit+> import System.IO+> import System.Directory+> import System.FilePath.Windows -> main = defaultMainWithHooks simpleUserHooks { runTests = TR.runPkgTestsHook }+main = defaultMainWithHooks simpleUserHooks -- { runTests = TR.runPkgTestsHook }++> main = let hooks = simpleUserHooks +> xpp = ("xpphs", ppXpp)+> xhs = ("xhs" , ppX)+> in defaultMainWithHooks hooks { hookedPreProcessors = xhs:xpp:knownSuffixHandlers }+>+> ppXpp :: BuildInfo -> LocalBuildInfo -> PreProcessor +> ppXpp build local =+> PreProcessor {+> platformIndependent = True,+> runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->+> do info verbosity (inFile++" is being preprocessed to "++outFile)+> let hscFile = replaceExtension inFile "hsc"+> runSimplePreProcessor (ppCpp build local) inFile hscFile verbosity+> handle <- openFile hscFile ReadMode+> source <- sGetContents handle+> hClose handle+> let newsource = unlines $ process $ lines source+> writeFile hscFile newsource+> runSimplePreProcessor (ppHsc2hs build local) hscFile outFile verbosity+> removeFile hscFile+> return ()+> }+>+> ppX :: BuildInfo -> LocalBuildInfo -> PreProcessor +> ppX build local =+> PreProcessor {+> platformIndependent = True,+> runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->+> do info verbosity (inFile++" is being preprocessed to "++outFile)+> handle <- openFile inFile ReadMode+> source <- sGetContents handle+> hClose handle+> writeFile outFile source+> return ()+> }+> +> process :: [String] -> [String]+> process ("":"":xs) = process ("":xs)+> process (x :xs) = case x of+> ('#':str) -> let str' = dropWhile isSpace str+> nm = takeWhile isNumber str'+> in if null nm+> then x : process xs+> else process xs+> _ -> x : process xs+> process [] = []+> +> sGetContents h = hGetContents h >>= \s -> length s `seq` return s
+ Tests/Test-Regression-Debug.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Contains the main entry point for the test interface+--+-----------------------------------------------------------------------------++module Main where++import Tests.TestRunner ( runLocalDebugTest )+import System.Exit ( exitSuccess )++main = do runLocalDebugTest+ exitSuccess
+ Tests/Test-Regression.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Contains the main entry point for the test interface+--+-----------------------------------------------------------------------------++module Main where++import Tests.TestRunner ( runLocalTest )+import System.Exit ( exitSuccess )++main = do runLocalTest+ exitSuccess
Tests/TestRunner.hs view
@@ -6,33 +6,23 @@ -- without any command line arguments. -- -- TestRunner currently uses runhaskell only to execute tests, which it assumes is already on the system path.-module Tests.TestRunner (runPkgTestsHook) where+module Tests.TestRunner ( runLocalTest, runLocalDebugTest ) where import Tests.FindFiles-import Distribution.PackageDescription (PackageDescription)-import Distribution.Simple hiding (runTests)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) --import Text.Regex.Posix import System.Cmd (system) import System.FilePath+import System.Exit import Data.List --- | The hook that a Cabal setup script using "Distribution.Simple" may use to automatically run tests.--- Sample use in Setup.hs:------ @--- import qualified TestSupport.TestRunner as TR--- import Distribution.Simple------ main = defaultMainWithHooks simpleUserHooks { runTests = TR.runPkgTestsHook }--- @-runPkgTestsHook :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()-runPkgTestsHook _ _ _ _ = runLocalTest- -- | Run and test all the files in Tests\src-runLocalTest :: IO ()-runLocalTest = runTests "Tests\\src\\"+runLocalTest :: IO () +runLocalTest = runTests "Tests\\src\\" False +-- | Run and test all the files in Tests\src with debugging enabled+runLocalDebugTest :: IO () +runLocalDebugTest = runTests "Tests\\src\\" True+ -- | Automatically runs tests in the package. -- -- runTests looks for all Haskell source files in the given subdirectory whose filename starts with \"Test\".@@ -42,9 +32,9 @@ -- Note that no provision is currently made for tests that hang, or for tests that return some status code. -- Just your basic stomp-through for now. runTests :: FilePath -- ^ the starting directory to search in- -> IO ()-runTests startPath = do files <- findFiles startPath isTest- mapM_ runTest files+ -> Bool -> IO ()+runTests startPath db = do files <- findFiles startPath isTest+ mapM_ (flip runTest db) files where isTest :: FilePath -> Bool isTest fpath = let filename = (takeFileName fpath) in "Test_" `isPrefixOf` filename && ".hs" `isSuffixOf` filename@@ -56,7 +46,13 @@ -- -- /TODO:/ get Cabal to require and configure the location of runhaskell for us? runTest :: FilePath -- ^ the path of the source file to run- -> IO ()-runTest test = putStrLn ( "[Running test: " ++ test ++ "]" ) - >> system ("hs2lib " ++ test) >> return ()+ -> Bool -> IO ()+runTest test db = do putStrLn ( "[Running test: " ++ test ++ "]" ) + -- exit <- system ("hs2lib " ++ test)+ -- exit <- system ("hs2lib -v2 " ++ test ++ " > " ++ test ++ ".log")+ let cmd = "hs2lib -v2 " ++ (if db then "--debug " else "") ++ test+ exit <- system cmd+ case exit of + ExitSuccess -> return ()+ ExitFailure _ -> exitFailure -- >> system ("hs2lib -v2 " ++ test ++ " > " ++ test ++ ".log") >> return ()
WinDll/Builder.hs view
@@ -14,10 +14,10 @@ module WinDll.Builder where -import WinDll.Session+import WinDll.Session.Hs2lib import WinDll.Utils.Feedback-import WinDll.CmdArgs-import WinDll.Version+import WinDll.CmdArgs.Hs2lib+import WinDll.Version.Hs2lib import Control.Monad
− WinDll/CmdArgs.hs
@@ -1,176 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Windll--- Copyright : (c) Tamar Christina 2009 - 2010--- License : BSD3--- --- Maintainer : tamar@zhox.com--- Stability : experimental--- Portability : portable------ A module to handle commandline arguments and parsing-----------------------------------------------------------------------------------module WinDll.CmdArgs where--import WinDll.Session-import WinDll.Version-import WinDll.Utils.Feedback-import WinDll.Structs.Structures-import WinDll.Utils.Pragma--import System.Directory-import System.Environment-import System.FilePath-import System.Console.GetOpt-import System.Exit--import Data.Maybe-import Data.Char-import Data.List--import Control.Monad---- | just renaming it to something that might make more sense to read in this module-type Config = Session - --- | Default configuration set for both the client and server.-defaultConfig :: Mode -> Config-defaultConfig Windows = newSession -defaultConfig Unix = let session = newSession - in session { call = CCall }- ---- | The parse mode for processArgs-type Mode = Platform---- | Read all the pragmas that contain options and then update the session with the new flags-enablePragmas :: Exec ()-enablePragmas =- do session <- get- inform _normal "Enabling commandline pragmas..."- let prgmas = (pragmas.workingset) session- cmds = getPragmas (upper_name ++ "_OPTS") prgmas- args = mainFile session : concatMap (\(Pragma _ x)->x) cmds- mode = platform session- - session' <- processConversionPragmas prgmas session- (result,errs) <- if (null args) then return (session',[]) else- liftIO $ do (result,errs) <- processArgs session' mode args- if (not.null) errs then putStrLn " Error(s):" else do return ()- mapM_ (\i -> putStrLn (" -> unrecognized input '"++i++"')")) errs- return (result,errs)- if null errs - then put result - else die "Error processing dynamic options"---- | Process args tries to parse the commandline arguments for either the client or the server. --- 1 = The session to initialize things with--- 2 = Mode to parse for--- 3 = arguments to parse--- return = Parsed config or error message-processArgs :: Config -> Mode -> [String] -> IO (Config, [String])-processArgs cfg mode argv= - case getOpt Permute opt argv of- (o,n,[]) -> process (foldl (flip id) cfg o) n opt- (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header opt))- where header = "Usage: " ++ name ++ " <input file> [OPTION...]"- name = if mode == Windows then exename ++ ".exe" else exename- opt = optDescr --if mode == Windows then optDescrClient else optDescrServer- process a r opt = - case Help `elem` opts of- True -> ioError (userError $ usageInfo header opt)- False -> case Version `elem` opts of- True -> putStrLn versionmsg >> exitSuccess- - False -> case r of- (x:[]) -> do path <- canonicalizePath (addTrailingPathSeparator (tempDIR a)) - return (a { mainFile = x- , platform = mode- , tempDIR = path - , absPath = guessPath x- },[])- _ -> ioError (userError $ usageInfo header opt)- where opts = options a- --- | Create a boolean flag-boolFlag :: String -> String -> (a->Bool->a) -> String -> [OptDescr (a->a)]-boolFlag short long update descr = [ template (update' True) short long descr- , template (update' False) "" ("no"++long) [] ]- where- template value short long descr = Option short [long] (NoArg value) descr- update' = flip update- --- | Collection of options available-optDescr = optVerbose- : optCall - : optNamespace- : optHackageBaseURL- : optOutDir- : optTempDir- : optOutFile- : optPlatform- : optVersion- : optHelp- : optLibmain- : optIncludes- : boolFlag "W" "warnings" (\cfg new -> cfg { warnings = new }) "print all warnings (Default True)"- ++ boolFlag "E" "warnings-as-errors" (\cfg new -> cfg { warnings_as_errors = new- , warnings = new || warnings cfg }) "treat all warnings as errors (Default False)"- ++ boolFlag "T" "keep-temp-files" (\cfg new -> cfg { keep_temps = new }) "keep all the temporary files generated by the pre-processor (Default False)"- ++ boolFlag "" "c#" (\cfg new -> cfg { csharp = new }) "enable C# file output"- ++ boolFlag "" "cpp" (\cfg new -> cfg { cpp = new }) "enable C/C++ file output (default True)"- ++ boolFlag "M" "lib" (\cfg new -> cfg { mvcpp = new }) "create a .LIB file for use with the Microsoft Visual C++ compiler. NOTE: This requires the %VSBIN% (case sensitive) environment variable to be set."- ++ boolFlag "d" "incl-def" (\cfg new -> cfg { incDef = new }) "Copy the generated .DEF file also to the specified output folder."- ++ boolFlag "" "link-dyn" (\cfg new -> cfg { link_dynamic = new }) ("If you have the dynamic version of all your libs installed you can use this flag. (this includes having installed " ++ exename ++ " using -dynamic)")- ++ boolFlag "" "preserve-comments" (\cfg new -> cfg { pres_comment = new }) "Enabling this allows you to preserve the haddock description comments of your functions in the generated C _FFI file (Default True)"- ++ boolFlag "" "preserve-foreigns" (\cfg new -> cfg { include_foreigns = new }) ("Enabling this will preserve and re-export any foreign declarations you already have declared in modules. NOTE: The Naming Convention must be the same as the generated functions. " ++ exename ++ " finds. (Default True)")- ++ boolFlag "" "no-dllmain" (\cfg new -> cfg { dllmanual = new }) "Enabling this will allow you to manual initialise the RTS. Dllmain will no longer make the call to HsInit(). -L and --libmain will be ignored. (Default True)"- ++ boolFlag "" "threaded" (\cfg new -> cfg { threaded = new - , dllmanual = new || dllmanual cfg }) "Enable the threaded RTS. This implies --no-dllmain. (Default False)"- --- | Collection of simple actions-optVerbose = Option ['v'] ["verbose","verbosity" ] (OptArg (\value cfg -> cfg { verbosity = fread (verbosity cfg) value }) "<number>") "set the verbosity level. Requires a number between 0 (off) and 3"-optCall = Option ['C'] ["convention" ] (ReqArg (\value cfg -> cfg { call = cread StdCall value }) "<StdCall | CCall>") "set the calling convention used in FFI (Default stdcall)"-optNamespace = Option ['n'] ["name" ] (ReqArg (\value cfg -> cfg { namespace = correct value }) "<name>") ("set the name to use in every generated code. (Default \"" ++ exename ++ "\")")-optHackageBaseURL = Option ['h'] ["hackage-base-url" ] (ReqArg (\value cfg -> cfg { hackage_base_url = value }) "<base-url>") "set the Hackage base url which will be used when doing code discovery"-optOutDir = Option [ ] ["outdir","output-directory"] (ReqArg (\value cfg -> cfg { outputDIR = value }) "<output-directory>") "set the output directory of the pre-processor (Default current folder)"-optTempDir = Option [ ] ["temp","temp-directory" ] (ReqArg (\value cfg -> cfg { tempDIR = value }) "<temp-directory>") "set the temporary directory of the pre-processor (Default system temp)"-optOutFile = Option ['o'] ["out","outFile" ] (ReqArg (\value cfg -> cfg { outputFile = value }) "<output-file>") "set the name of the output file (Default derived from input and platform)"-optPlatform = Option ['P'] ["platform" ] (ReqArg (\value cfg -> cfg { platform = cread Windows value }) "<Windows | Unix>") "set the platform to compile for (Defaul current system)"-optIncludes = Option ['I'] ["includes" ] (ReqArg (\value cfg -> cfg { includes = value : (includes cfg) }) "file") "include extra files in the pipeline. (external definitions)"-optHelp = Option ['?'] ["h","help" ] (NoArg (\cfg -> cfg {options = Help:(options cfg)}) ) "Show this help screen"-optVersion = Option [ ] ["version" ] (NoArg (\cfg -> cfg {options = Version:(options cfg)}) ) "Show program version information"-optLibmain = Option ['L'] ["libmain" ] (ReqArg (\value cfg -> cfg { dllmain = value }) "<path>") "set the dllmain file to be used by when compiling the library"-optIncForeign = Option [ ] ["native-symbols" ] (ReqArg (\value cfg -> cfg { native_symbols = value : (native_symbols cfg) }) "<path>") "include the .DEF file specified here into the final generated Exports table."--fread :: Int -> Maybe String -> Int-fread c q = let p = maybe 1 (read' 1) q- in if (p + c) > 3 || (c + p) < 0 then 1 else (c+p)- -cread c q = let p = reads q- hasValue = not $ null p- value = if hasValue then fst $ head p else c- in value- --- | Get the read in namespace name into a useable format-correct :: String -> String-correct [] = []-correct (x:xs) = toUpper x : filter isAlphaNum xs---- | Because read can fail for parsing stuff other than strings. --- this function is used to either accept the change. or use the default-read' :: Int -> String -> Int-read' def str = let r = reads str - in if null r then def else (fst.head) r---- | The main parse function to call. It takes a mode as parameters and takes a pointer--- to a function to call should it all succeed.-goArgs :: Mode -> (Config -> IO ()) -> IO ()-goArgs mode call =- do args <- getArgs- (result,errs) <- processArgs (defaultConfig mode) mode args- if (not.null) errs then putStrLn " Errors:" else do return ()- mapM_ (\i -> putStrLn (" -> unrecognized input '"++i++"')")) errs- if null errs then call result else do return ()
+ WinDll/CmdArgs/Debug.hs view
@@ -0,0 +1,120 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- A module to handle commandline arguments and parsing+-- for the main program.+--+-----------------------------------------------------------------------------++module WinDll.CmdArgs.Debug where++import WinDll.Session.Debug+import WinDll.Version.Debug++import System.Directory+import System.Environment+import System.FilePath+import System.Console.GetOpt+import System.Exit++import Data.Maybe+import Data.Char+import Data.List++import Control.Monad++-- | just renaming it to something that might make more sense to read in this module+type Config = Session ++-- | The parse mode for processArgs+type Mode = Platform++-- | Process args tries to parse the commandline arguments for either the client or the server. +-- 1 = The session to initialize things with+-- 2 = Mode to parse for+-- 3 = arguments to parse+-- return = Parsed config or error message+processArgs :: Config -> Mode -> [String] -> IO (Config, [String])+processArgs cfg mode argv= + case getOpt Permute opt argv of+ (o,n,[]) -> process (foldl (flip id) cfg o) n opt+ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header opt))+ where header = "Usage: " ++ name ++ " <input file> [OPTION...]"+ name = if mode == Windows then exename ++ ".exe" else exename+ opt = optDescr --if mode == Windows then optDescrClient else optDescrServer+ process a r opt = + case Help `elem` opts of+ True -> ioError (userError $ usageInfo header opt)+ False -> case Version `elem` opts of+ True -> putStrLn versionmsg >> exitSuccess+ + False -> case r of+ (x:[]) -> do base <- getCurrentDirectory+ let dir = takeDirectory (normalise x)+ bin = combine base dir+ path <- guessPath x+ return (a { mainFile = x+ , absPath = path+ , baseDir = bin+ },[])+ _ -> ioError (userError $ usageInfo header opt)+ where opts = options a+ +-- | Create a boolean flag+boolFlag :: String -> String -> (a->Bool->a) -> String -> [OptDescr (a->a)]+boolFlag short long update descr = [ template (update' True) short long descr+ , template (update' False) "" ("no"++long) [] ]+ where+ template value short long descr = Option short [long] (NoArg value) descr+ update' = flip update+ +-- | Collection of options available+optDescr = optVerbose+ : optOutDir+ : optOutFile+ : optVersion+ : [optHelp]+ +-- | Collection of simple actions+optVerbose = Option ['v'] ["verbose","verbosity" ] (OptArg (\value cfg -> cfg { verbosity = fread (verbosity cfg) value }) "<number>") "set the verbosity level. Requires a number between 0 (off) and 3"+optOutDir = Option [ ] ["outdir","output-directory"] (ReqArg (\value cfg -> cfg { outputDIR = value }) "<output-directory>") "set the output directory of the pre-processor (Default current folder)"+optOutFile = Option ['o'] ["out","outFile" ] (ReqArg (\value cfg -> cfg { outputFile = value }) "<output-file>") "set the name of the output file (Default derived from input and platform)"+optHelp = Option ['?'] ["h","help" ] (NoArg (\cfg -> cfg {options = Help:(options cfg)}) ) "Show this help screen"+optVersion = Option [ ] ["version" ] (NoArg (\cfg -> cfg {options = Version:(options cfg)}) ) "Show program version information"++fread :: Int -> Maybe String -> Int+fread c q = let p = maybe 1 (read' 1) q+ in if (p + c) > 3 || (c + p) < 0 then 1 else (c+p)+ +cread c q = let p = reads q+ hasValue = not $ null p+ value = if hasValue then fst $ head p else c+ in value+ +-- | Get the read in namespace name into a useable format+correct :: String -> String+correct [] = []+correct (x:xs) = toUpper x : filter isAlphaNum xs++-- | Because read can fail for parsing stuff other than strings. +-- this function is used to either accept the change. or use the default+read' :: Int -> String -> Int+read' def str = let r = reads str + in if null r then def else (fst.head) r++-- | The main parse function to call. It takes a mode as parameters and takes a pointer+-- to a function to call should it all succeed.+goArgs :: Mode -> (Config -> IO ()) -> IO ()+goArgs mode call =+ do args <- getArgs+ (result,errs) <- processArgs newSession mode args+ if (not.null) errs then putStrLn " Errors:" else do return ()+ mapM_ (\i -> putStrLn (" -> unrecognized input '"++i++"')")) errs+ if null errs then call result else do return ()
+ WinDll/CmdArgs/Hs2lib.hs view
@@ -0,0 +1,183 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- A module to handle commandline arguments and parsing+-- for the main program.+--+-----------------------------------------------------------------------------++module WinDll.CmdArgs.Hs2lib where++import WinDll.Session.Hs2lib+import WinDll.Version.Hs2lib+import WinDll.Utils.Feedback+import WinDll.Structs.Structures+import WinDll.Utils.Pragma++import System.Directory+import System.Environment+import System.FilePath+import System.Console.GetOpt+import System.Exit++import Data.Maybe+import Data.Char+import Data.List++import Control.Monad++-- | just renaming it to something that might make more sense to read in this module+type Config = Session + +-- | Default configuration set for both the client and server.+defaultConfig :: Mode -> Config+defaultConfig Windows = newSession +defaultConfig Unix = let session = newSession + in session { call = CCall }+ ++-- | The parse mode for processArgs+type Mode = Platform++-- | Read all the pragmas that contain options and then update the session with the new flags+enablePragmas :: Exec ()+enablePragmas =+ do session <- get+ inform _normal "Enabling commandline pragmas..."+ let prgmas = (pragmas.workingset) session+ cmds = getPragmas (upper_name ++ "_OPTS") prgmas+ args = mainFile session : concatMap (\(Pragma _ x)->x) cmds+ mode = platform session+ + session' <- processConversionPragmas prgmas session+ (result,errs) <- if (null args) then return (session',[]) else+ liftIO $ do (result,errs) <- processArgs session' mode args+ if (not.null) errs then putStrLn " Error(s):" else do return ()+ mapM_ (\i -> putStrLn (" -> unrecognized input '"++i++"')")) errs+ return (result,errs)+ if null errs + then put result + else die "Error processing dynamic options"++-- | Process args tries to parse the commandline arguments for either the client or the server. +-- 1 = The session to initialize things with+-- 2 = Mode to parse for+-- 3 = arguments to parse+-- return = Parsed config or error message+processArgs :: Config -> Mode -> [String] -> IO (Config, [String])+processArgs cfg mode argv= + case getOpt Permute opt argv of+ (o,n,[]) -> process (foldl (flip id) cfg o) n opt+ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header opt))+ where header = "Usage: " ++ name ++ " <input file> [OPTION...]"+ name = if mode == Windows then exename ++ ".exe" else exename+ opt = optDescr --if mode == Windows then optDescrClient else optDescrServer+ process a r opt = + case Help `elem` opts of+ True -> ioError (userError $ usageInfo header opt)+ False -> case Version `elem` opts of+ True -> putStrLn versionmsg >> exitSuccess+ + False -> case r of+ (x:[]) -> do path <- canonicalizePath (addTrailingPathSeparator (tempDIR a))+ base <- getCurrentDirectory+ abs_path <- guessPath x+ let dir = takeDirectory (normalise x)+ bin = combine base dir+ return (a { mainFile = x+ , platform = mode+ , tempDIR = path + , absPath = abs_path+ , baseDir = base+ },[])+ _ -> ioError (userError $ usageInfo header opt)+ where opts = options a+ +-- | Create a boolean flag+boolFlag :: String -> String -> (a->Bool->a) -> String -> [OptDescr (a->a)]+boolFlag short long update descr = [ template (update' True) short long descr+ , template (update' False) "" ("no"++long) [] ]+ where+ template value short long descr = Option short [long] (NoArg value) descr+ update' = flip update+ +-- | Collection of options available+optDescr = optVerbose+ : optCall + : optNamespace+ : optHackageBaseURL+ : optOutDir+ : optTempDir+ : optOutFile+ : optPlatform+ : optVersion+ : optHelp+ : optLibmain+ : optIncludes+ : boolFlag "W" "warnings" (\cfg new -> cfg { warnings = new }) "print all warnings (Default True)"+ ++ boolFlag "E" "warnings-as-errors" (\cfg new -> cfg { warnings_as_errors = new+ , warnings = new || warnings cfg }) "treat all warnings as errors (Default False)"+ ++ boolFlag "T" "keep-temp-files" (\cfg new -> cfg { keep_temps = new }) "keep all the temporary files generated by the pre-processor (Default False)"+ ++ boolFlag "" "c#" (\cfg new -> cfg { csharp = new }) "enable C# file output"+ ++ boolFlag "" "cpp" (\cfg new -> cfg { cpp = new }) "enable C/C++ file output (default True)"+ ++ boolFlag "M" "lib" (\cfg new -> cfg { mvcpp = new }) "create a .LIB file for use with the Microsoft Visual C++ compiler. NOTE: This requires the %VSBIN% (case sensitive) environment variable to be set."+ ++ boolFlag "d" "incl-def" (\cfg new -> cfg { incDef = new }) "Copy the generated .DEF file also to the specified output folder."+ ++ boolFlag "" "link-dyn" (\cfg new -> cfg { link_dynamic = new }) ("If you have the dynamic version of all your libs installed you can use this flag. (this includes having installed " ++ exename ++ " using -dynamic)")+ ++ boolFlag "" "debug" (\cfg new -> cfg { debugging = new }) ("Enable debugging support which enabled memory profiling.")+ ++ boolFlag "" "preserve-comments" (\cfg new -> cfg { pres_comment = new }) "Enabling this allows you to preserve the haddock description comments of your functions in the generated C _FFI file (Default True)"+ ++ boolFlag "" "preserve-foreigns" (\cfg new -> cfg { include_foreigns = new }) ("Enabling this will preserve and re-export any foreign declarations you already have declared in modules. NOTE: The Naming Convention must be the same as the generated functions. " ++ exename ++ " finds. (Default True)")+ ++ boolFlag "" "no-dllmain" (\cfg new -> cfg { dllmanual = new }) "Enabling this will allow you to manual initialise the RTS. Dllmain will no longer make the call to HsInit(). -L and --libmain will be ignored. (Default True)"+ ++ boolFlag "" "threaded" (\cfg new -> cfg { threaded = new + , dllmanual = new || dllmanual cfg }) "Enable the threaded RTS. This implies --no-dllmain. (Default False)"+ +-- | Collection of simple actions+optVerbose = Option ['v'] ["verbose","verbosity" ] (OptArg (\value cfg -> cfg { verbosity = fread (verbosity cfg) value }) "<number>") "set the verbosity level. Requires a number between 0 (off) and 3"+optCall = Option ['C'] ["convention" ] (ReqArg (\value cfg -> cfg { call = cread StdCall value }) "<StdCall | CCall>") "set the calling convention used in FFI (Default stdcall)"+optNamespace = Option ['n'] ["name" ] (ReqArg (\value cfg -> cfg { namespace = correct value }) "<name>") ("set the name to use in every generated code. (Default \"" ++ exename ++ "\")")+optHackageBaseURL = Option ['h'] ["hackage-base-url" ] (ReqArg (\value cfg -> cfg { hackage_base_url = value }) "<base-url>") "set the Hackage base url which will be used when doing code discovery"+optOutDir = Option [ ] ["outdir","output-directory"] (ReqArg (\value cfg -> cfg { outputDIR = value }) "<output-directory>") "set the output directory of the pre-processor (Default current folder)"+optTempDir = Option [ ] ["temp","temp-directory" ] (ReqArg (\value cfg -> cfg { tempDIR = value }) "<temp-directory>") "set the temporary directory of the pre-processor (Default system temp)"+optOutFile = Option ['o'] ["out","outFile" ] (ReqArg (\value cfg -> cfg { outputFile = value }) "<output-file>") "set the name of the output file (Default derived from input and platform)"+optPlatform = Option ['P'] ["platform" ] (ReqArg (\value cfg -> cfg { platform = cread Windows value }) "<Windows | Unix>") "set the platform to compile for (Defaul current system)"+optIncludes = Option ['I'] ["includes" ] (ReqArg (\value cfg -> cfg { includes = value : (includes cfg) }) "file") "include extra files in the pipeline. (external definitions)"+optHelp = Option ['?'] ["h","help" ] (NoArg (\cfg -> cfg {options = Help:(options cfg)}) ) "Show this help screen"+optVersion = Option [ ] ["version" ] (NoArg (\cfg -> cfg {options = Version:(options cfg)}) ) "Show program version information"+optLibmain = Option ['L'] ["libmain" ] (ReqArg (\value cfg -> cfg { dllmain = value }) "<path>") "set the dllmain file to be used by when compiling the library"+optIncForeign = Option [ ] ["native-symbols" ] (ReqArg (\value cfg -> cfg { native_symbols = value : (native_symbols cfg) }) "<path>") "include the .DEF file specified here into the final generated Exports table."++fread :: Int -> Maybe String -> Int+fread c q = let p = maybe 1 (read' 1) q+ in if (p + c) > 3 || (c + p) < 0 then 1 else (c+p)+ +cread c q = let p = reads q+ hasValue = not $ null p+ value = if hasValue then fst $ head p else c+ in value+ +-- | Get the read in namespace name into a useable format+correct :: String -> String+correct [] = []+correct (x:xs) = toUpper x : filter isAlphaNum xs++-- | Because read can fail for parsing stuff other than strings. +-- this function is used to either accept the change. or use the default+read' :: Int -> String -> Int+read' def str = let r = reads str + in if null r then def else (fst.head) r++-- | The main parse function to call. It takes a mode as parameters and takes a pointer+-- to a function to call should it all succeed.+goArgs :: Mode -> (Config -> IO ()) -> IO ()+goArgs mode call =+ do args <- getArgs+ (result,errs) <- processArgs (defaultConfig mode) mode args+ if (not.null) errs then putStrLn " Errors:" else do return ()+ mapM_ (\i -> putStrLn (" -> unrecognized input '"++i++"')")) errs+ if null errs then call result else do return ()
WinDll/CodeGen/C.hs view
@@ -20,9 +20,10 @@ import WinDll.Utils.Feedback import WinDll.Builder import WinDll.Identifier -import WinDll.Session +import WinDll.Session.Hs2lib import WinDll.Structs.C +import qualified WinDll.Structs.C as C import WinDll.Structs.MShow.MShow import WinDll.Structs.MShow.C import WinDll.Structs.Folds.HaskellSrcExts @@ -58,12 +59,21 @@ exports = modExports modInfo callbacks = modCallbacks modInfo callconv = call session - defs = natives ++ manualdef + defs = natives ++ manualdef ++ debugdefs + natDefs = natives ++ debugdefs + modnm = [] ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) + ptType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "Ptr"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) + ftType = Exts.TyFun ptType ctType manualdef = if dllmanual session -- | we're going to threat the Hs* functions as if they were just normal haskell functions, with type IO () - then [HaskellExport callconv ann $ Export "HsStart" "HsStart" ctType ctType - ,HaskellExport callconv ann $ Export "HsEnd" "HsEnd" ctType ctType] + then [HaskellExport callconv ann $ Export "HsStart" "HsStart" ctType ctType modnm + ,HaskellExport callconv ann $ Export "HsEnd" "HsEnd" ctType ctType modnm] else [] + debugdefs = if debugging session + then case callconv of + StdCall -> [HaskellExport callconv ann $ Export "Ex.freeS" "freeS" ftType ftType modnm] + CCall -> [HaskellExport callconv ann $ Export "Ex.freeC" "freeC" ftType ftType modnm] + else [] inform _detail "Creating export definition file" extra_defs <- liftIO $ fmap (fmap (" "++)) $ mapM readFile symb @@ -75,11 +85,11 @@ createComponent (name++".h") (return $ mkHeader ++ (mshow $ generateHeaderFile ann callconv callbacks datatypes)) inform _detail "Creating C/C++ function include header file" - createComponent (name++"_FFI.h") (generateFFIHeader ann (call session) name exports natives manualdef) + createComponent (name++"_FFI.h") (generateFFIHeader ann (call session) name exports natDefs manualdef) -- | Generate the export list from a list of defined FFI Export systems createLocalExports :: Ann -> HaskellExport -> [String] -createLocalExports ann (HaskellExport clp _ (Export _ a t _)) = +createLocalExports ann (HaskellExport clp _ (Export _ a t _ modnm)) = case clp of StdCall -> [" _" ++ a ++ "@" ++ getSize ann t ++ " = " ++ a ++ "@" ++ getSize ann t," " ++ a ++ "@" ++ getSize ann t] CCall -> [" " ++ a] @@ -88,8 +98,8 @@ generateExports :: Ann -> CallConvention -> String -> [Export] -> [String] generateExports ann clp name funcs = ("LIBRARY " ++ name) : "EXPORTS" : case clp of - StdCall -> concatMap (\(Export _ a t _)->[" _" ++ a ++ "@" ++ getSize ann t ++ " = " ++ a ++ "@" ++ getSize ann t," " ++ a ++ "@" ++ getSize ann t]) funcs - CCall -> map (\(Export _ a t _)->" " ++ a) funcs + StdCall -> concatMap (\(Export _ a t _ modnm)->[" _" ++ a ++ "@" ++ getSize ann t ++ " = " ++ a ++ "@" ++ getSize ann t," " ++ a ++ "@" ++ getSize ann t]) funcs + CCall -> map (\(Export _ a t _ modnm)->" " ++ a) funcs -- | Return the size of a specified type getSize ann x = let types = createCType (annWorkingSetC ann) x @@ -103,7 +113,7 @@ = do session <- get list <- getDocumentationInfo -- declare exported functions - let types = concatMap (\(Export _ n t _)-> + let types = concatMap (\(Export _ n t _ modnm)-> let x = createCType (annWorkingSetC ann) t -- genAndLookupC t restype = last x rest = case length x > 1 of @@ -157,7 +167,7 @@ -- | Create an enum list from a list of Constructors mkEnum name t = DataEnum name (map enum t) - where enum (Constr name _) = filter isAlphaNum name --filter isAlpha (map toLower name) + where enum (Constr name ft _) = filter isAlphaNum name --filter isAlpha (map toLower name) -- | Generate complete file from given structures generateHeaderFile :: Ann -> CallConvention -> [Callback] -> DataTypes -> C @@ -174,7 +184,7 @@ where generateStructs :: DataType -> [DataField] -- ("struct " ++ name ++ ";") : -- generateStructs (DataType name e [_] _) = [Forward Struct name] -- treat datastructures with only 1 constructor as a newtype - generateStructs (DataType name e t _) = Forward Struct name : map (\(Constr n _)->Forward Struct n) t + generateStructs (DataType name e t _) = Forward Struct name : map (\(Constr n _ _)->Forward Struct n) t generateStructs (NewType name e _ _) = [Forward Struct name] --generateStructs (NewType name e t _) = generateStructs (DataType name e [t] NoTag) @@ -182,20 +192,20 @@ generateTopLevelStruct (DataType name e t _) = case length t `compare` 1 of GT -> join [wrapStruct Struct name entries, mkStructs e t, mkUnion name t] - LT -> join [wrapStruct Struct name [Value Union (name++"Union") Normal (Just "elt")],mkStructs e t,mkUnion name t] + LT -> join [wrapStruct Struct name [Value Union (name++"Union") C.Normal (Just "elt")],mkStructs e t,mkUnion name t] EQ -> generateTopLevelStruct (NewType name e (head t) NoTag) -- treat as newtype. - where entries = [Value ENum ("List"++name) Normal (Just "tag"),Value Union (name++"Union") Pointer (Just "elt")] + where entries = [Value ENum ("List"++name) C.Normal (Just "tag"),Value Union (name++"Union") Pointer (Just "elt")] generateTopLevelStruct (NewType name e t NoTag) = wrapStruct Struct name (concatMap inline' (mkStruct e t)) mkStructs :: TypeNames -> [DataType] -> [DataField] mkStructs types constrs = concatMap (mkStruct types) constrs mkStruct :: TypeNames -> DataType -> [DataField] - mkStruct types (Constr name values) = wrapStruct Struct name (concatMap mkLine values) + mkStruct types (Constr name ft values) = wrapStruct Struct name (concatMap mkLine values) where lpc = mshowM 1 . lc types -- TODO: rewrite this to support type applied types in datatypes mkLine x = let ann = antAnn x - base = Value VAlue (lpc (antType x)) Normal (Just (antName x)) - size = Value VAlue (lpc (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int")) Normal (Just (antName x ++ "_Size")) + base = Value VAlue (lpc (antType x)) C.Normal (Just (antName x)) + size = Value VAlue (lpc (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int")) C.Normal (Just (antName x ++ "_Size")) in case annArrayIsList ann of True -> [base, size] False -> [base] @@ -204,7 +214,7 @@ mkUnion :: Name -> DataTypes -> [DataField] mkUnion name types = wrapStruct Union (name++"Union") (map mkEntry types) -- name ++ "* " for pointers - where mkEntry (Constr name _) = Value Struct name Normal (Just $ "var_" ++ filter isAlphaNum name ) --(map toLower name)) + where mkEntry (Constr name ft _) = Value Struct name C.Normal (Just $ "var_" ++ filter isAlphaNum name ) --(map toLower name)) wrapStruct :: CodeGen -> String -> [DataField] -> [DataField] wrapStruct Struct n l = [Field NormalDef Struct n [] l]-- TypeDef Struct n n l]
WinDll/CodeGen/CSharp/CSharp.hs view
@@ -21,10 +21,11 @@ import WinDll.Utils.Feedback import WinDll.Builder import WinDll.Identifier-import WinDll.Session+import WinDll.Session.Hs2lib import WinDll.Structs.C hiding (Normal) import WinDll.Structs.CSharp+import qualified WinDll.Structs.CSharp as Cs import WinDll.Structs.MShow.MShow import WinDll.Structs.MShow.CSharp import WinDll.Structs.MShow.C@@ -58,22 +59,31 @@ exports = modExports modInfo callbacks = modCallbacks modInfo callconv = call session- defs = natives ++ manualdef+ defs = natives ++ manualdef ++ debugdefs+ natDefs = natives ++ debugdefs+ modnm = [] ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon))+ ptType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "Ptr"))) (Exts.TyCon (Exts.Special Exts.UnitCon))+ ftType = Exts.TyFun ptType ctType manualdef = if dllmanual session -- | we're going to threat the Hs* functions as if they were just normal haskell functions, with type IO ()- then [HaskellExport callconv ann $ Export "HsStart" "HsStart" ctType ctType - ,HaskellExport callconv ann $ Export "HsEnd" "HsEnd" ctType ctType]+ then [HaskellExport callconv ann $ Export "HsStart" "HsStart" ctType ctType modnm+ ,HaskellExport callconv ann $ Export "HsEnd" "HsEnd" ctType ctType modnm] else []+ debugdefs = if debugging session + then case callconv of+ StdCall -> [HaskellExport callconv ann $ Export "Ex.freeS" "freeS" ftType ftType modnm]+ CCall -> [HaskellExport callconv ann $ Export "Ex.freeC" "freeC" ftType ftType modnm]+ else [] inform _detail "Creating C# structures & function header file" createComponent (name++".cs") (return $ mshow $ generateCsFile exports doclist callbacks - natives manualdef callconv+ natDefs manualdef callconv name datatypes ann) generateCsFile :: [Export] -> IndexedInterface -> [Callback] -> [HaskellExport] -> [HaskellExport] -> CallConvention -> String -> DataTypes -> Ann -> CSharp generateCsFile exps docs calls natives defs callconv classname dtypes ann- = let makeCsExport (Export _ n t _) =+ = let makeCsExport (Export _ n t _ modnm) = let x = createCsType (annWorkingSetCs ann) t restype = swapList (last x) rest = case length x > 1 of@@ -87,7 +97,7 @@ else "CallingConvention=CallingConvention.StdCall" comments = (n ++ " ::" ++ (resp $ mshowM 2 t)) : (maybe [] id (fmap (\x->map ("// "++) (description x)) $ M.lookup n docs)) in CsExport { cseComments = comments- , cseTopAttr = [Attr Normal "DllImport" ["\"" ++ classname++".dll\"", callc, "CharSet = CharSet.Unicode"]+ , cseTopAttr = [Attr Cs.Normal "DllImport" ["\"" ++ classname++".dll\"", callc, "CharSet = CharSet.Unicode"] ] ++ lookupRetAttr restype , cseName = n , cseRetType = restype@@ -98,7 +108,7 @@ makeCsCallback (Callback nm t _ _ _) = let conv = if callconv == CCall then "CallingConvention.Cdecl" else "CallingConvention.StdCall"- attr = [Attr Normal "UnmanagedFunctionPointer" [conv]]+ attr = [Attr Cs.Normal "UnmanagedFunctionPointer" [conv]] x = createCsType (annWorkingSetCs ann) t restype = last x rest = case length x > 1 of@@ -142,8 +152,8 @@ upgradeField (Value{} ) = error "Value declarations are not directly supported by this function" upgradeField (Field NormalDef kind name _ args) = let attr = case kind of - Struct -> [Attr Normal "StructLayout" ["LayoutKind.Sequential", "CharSet=CharSet.Unicode"]]- Union -> [Attr Normal "StructLayout" ["LayoutKind.Explicit" , "CharSet=CharSet.Unicode"]]+ Struct -> [Attr Cs.Normal "StructLayout" ["LayoutKind.Sequential", "CharSet=CharSet.Unicode"]]+ Union -> [Attr Cs.Normal "StructLayout" ["LayoutKind.Explicit" , "CharSet=CharSet.Unicode"]] _ -> error "unsupported Kind value in c# conversion" styp = case kind of Struct -> CsTStruct@@ -152,7 +162,7 @@ mkElements (Value _ name typ (Just nm)) = let stype = name ++ mshow typ sattr = lookupAttr stype attr = case kind of- Union -> Attr Normal "FieldOffset" ["0"] : sattr+ Union -> Attr Cs.Normal "FieldOffset" ["0"] : sattr _ -> sattr in Argument attr stype nm mkElements x = error $ "Argument type not supported: " ++ show x @@ -166,17 +176,17 @@ -- | Lookup Attributes for struct paramaters -- these get prefixed with 'param: ' lookupArgAttr :: String -> [Attr]-lookupArgAttr ty = [ Attr Param k v | (Attr _ k v) <- lookupAttr ty]+lookupArgAttr ty = [ Attr Cs.Param k v | (Attr _ k v) <- lookupAttr ty] -- | Lookup Attributes for fucntion return paramaters -- these get prefixed with 'return: ' lookupRetAttr :: String -> [Attr]-lookupRetAttr ty = [ Attr Return k v | (Attr _ k v) <- lookupAttr ty ]+lookupRetAttr ty = [ Attr Cs.Return k v | (Attr _ k v) <- lookupAttr ty ] -- | Perform a lookup of marshalling attributes for a type lookupAttr :: String -> [Attr] lookupAttr ty = if "CBF" `isPrefixOf` ty- then [Attr Normal "MarshalAs" ["UnmanagedType.FunctionPtr"]]+ then [Attr Cs.Normal "MarshalAs" ["UnmanagedType.FunctionPtr"]] else maybe [] id (lookup ty attlist) -- | List containing mapping to C# Attributes from type @@ -206,4 +216,4 @@ ,("Rational" , mk "I8" ) ,("StablePtr" , [] ) ,("()" , [] )]- where mk x = [Attr Normal "MarshalAs" ["UnmanagedType." ++ x]]+ where mk x = [Attr Cs.Normal "MarshalAs" ["UnmanagedType." ++ x]]
WinDll/CodeGen/Haskell.hs view
@@ -23,11 +23,11 @@ import WinDll.Structs.Folds.Haskell import WinDll.Utils.Pragma -import WinDll.Session+import WinDll.Session.Hs2lib import WinDll.Builder import WinDll.Utils.Feedback import WinDll.Identifier-import WinDll.Parsers+import WinDll.Parsers.Hs2lib import WinDll.Lib.NativeMapping import WinDll.Lib.Instances @@ -74,6 +74,7 @@ _exports = modExports modInfo callbacks = modCallbacks modInfo stables = modStablePtrs modInfo+ debug = debugging session (simple_datatypes, spec_datatypes) = modDatatypes modInfo @@ -91,18 +92,19 @@ in TypeDecL (y++"Ptr") typenames $ mkPtr (foldr1 Exts.TyApp typevars) -- end pragma code - ann <- makeSessionAnn- - let (imp,lets) = insertHeaders- specials = getSpecializations spec_datatypes spco+ ann <- makeSessionAnn+ (imp,lets) <- insertHeaders+ + let specials = getSpecializations spec_datatypes spco result = HaskellFile name [HaskellComment "Autogenerated from WinDll. Do NOT modify unless you know what you're doing."]- [Pragma LANGUAGE "ForeignFunctionInterface"+ ([Pragma LANGUAGE "ForeignFunctionInterface" -- ,Pragma LANGUAGE "UndecidableInstances" -- is this one really needed? ,Pragma LANGUAGE "TypeSynonymInstances" ,Pragma LANGUAGE "FlexibleInstances"- ,Pragma LANGUAGE "MultiParamTypeClasses"]+ ,Pragma LANGUAGE "MultiParamTypeClasses"+ ] ++ if debug then [Pragma LANGUAGE "CPP"] else []) (imp ++ map Import deps ++ prag_imps) lets [LocalInclude (name++".h")@@ -120,7 +122,7 @@ callbacks stables - return (mshowWithPath fullfile name bdir result)+ return (mshowWithPath debug fullfile name bdir result) -- | Create a simple identiy class from the given type generateInstanceCode :: Type -> [String]@@ -162,8 +164,8 @@ -- | Generate the import definitions mkImport :: Ann -> CallConvention -> HaskellCallback -> [HaskellImport]-mkImport ann cc cb = [HaskellImport cc ann (Export ("mk" ++ name) "wrapper" tyTo otype)- ,HaskellImport cc ann (Export ("dyn" ++ name) "dynamic" tyFrom otype)]+mkImport ann cc cb = [HaskellImport cc ann (Export ("mk" ++ name) "wrapper" tyTo otype modnm)+ ,HaskellImport cc ann (Export ("dyn" ++ name) "dynamic" tyFrom otype modnm)] where tyTo = Exts.TyFun newty (Exts.TyApp@@ -176,6 +178,7 @@ name = cbName cb newty = cbNewType cb otype = cbInputType cb+ modnm = annModule ann -- | Generates the type definitions for the callback functions. mkCallbackTypes :: HaskellCallback -> [TypeDecL]@@ -197,11 +200,12 @@ spaceMap f (x:xs) = f x : [] : spaceMap f xs -- | Insert standard headings needed for Haskell's HSC PreProcessor-insertHeaders :: ([Import],[HSC_Let])-insertHeaders = (map Import (stdImports ++ - ["Control.Monad"- ,"Control.Monad.Instances"])- ,[HSC_Let "alignment t = \"%lu\", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)"])+insertHeaders :: Exec ([Import],[HSC_Let])+insertHeaders = do stdi <- stdImports + return (map Import (stdi ++ + ["Control.Monad"+ ,"Control.Monad.Instances"])+ ,[HSC_Let "alignment t = \"%lu\", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)"]) -- | Create the enum list from the Datatype if required. -- No enum is needed for newtypes or when only 1 constructor is available for the Data instance@@ -211,7 +215,7 @@ -- | Create an enum list from a list of Constructors mkEnum name t = DataEnum name (map enum t)- where enum (Constr name _) = filter isAlphaNum name -- filter isAlpha (map toLower name) + where enum (Constr name _ _) = filter isAlphaNum name -- filter isAlpha (map toLower name) -- | Create the Storage instances needed by Haskell's HSC PreProcessor generateStorageCode :: Ann -> Bool -> DataType -> HaskellStorable@@ -226,10 +230,13 @@ sizes :: [(Name,Int)] sizes = map getSize t where getSize :: DataType -> (Name,Int)- getSize (Constr name ntypes) = (name, length ntypes)+ getSize (Constr name ft ntypes) = (name, length ntypes) in HSStorable name sizes "ptr" e esc po [peeks] ann + dbg = annDebug ann+ modnm = annModule ann+ isNewType (NewType _ _ _ _) = True isNewType (DataType _ _ [x] _) = True -- also inline datatypes with just 1 constructor isNewType _ = False@@ -241,24 +248,24 @@ rollFn fn name newtpe constrs =join $ zipWith ($) (map (\c a -> fn a name newtpe c) constrs) [0..(length constrs - 1)] mkPoke :: [String] -> Func- mkPoke e dna newtpe (Constr name ntypes) = + mkPoke e dna newtpe (Constr name ft ntypes) = let col = case newtpe of False -> [PokeTag dna "tag" _ptr (PokeValue enum)- ,NewPtr _newptr dnamod+ ,NewPtr dbg _newptr dnamod ] ++ inner ++ [PokeTag dna "elt" _ptr (PokeValue _newptr)]- True -> concat $ zipWith (\x (c,b)->let base = PokeTag dna (antName x) _ptr (PokeVar esc b Nothing c ann)+ True -> concat $ zipWith (\x (c,b)->let base = PokeTag dna (antName x) _ptr (PokeVar dbg esc b Nothing c ann) msg = "(length " ++ b ++ ")"- size = PokeTag name (antName x++"_Size") _ptr (PokeVar esc (b++"s") (Just msg) (Exts.TyCon (Exts.UnQual (Exts.Ident "CInt"))) ann)+ size = PokeTag name (antName x++"_Size") _ptr (PokeVar dbg esc (b++"s") (Just msg) (Exts.TyCon (Exts.UnQual (Exts.Ident "CInt"))) ann) in if annArrayIsList (antAnn x) then [base, size] else [base]) ntypes aName- in HSPoke name (length ntypes) col+ in HSPoke name modnm (length ntypes) col where _ptr = "ptr" _newptr = "newptr" ++ show (unsafePerformIO $ getStdRandom (randomR (0::Int,1000000))) inner = guard (not $ null ntypes) - >> concat (zipWith (\x (c,b)->let base = PokeTag name (antName x) _newptr (PokeVar esc b Nothing c ann)+ >> concat (zipWith (\x (c,b)->let base = PokeTag name (antName x) _newptr (PokeVar dbg esc b Nothing c ann) msg = "(length " ++ b ++ ")"- size = PokeTag name (antName x++"_Size") _newptr (PokeVar esc (b++"s") (Just msg) (Exts.TyCon (Exts.UnQual (Exts.Ident "CInt"))) ann)+ size = PokeTag name (antName x++"_Size") _newptr (PokeVar dbg esc (b++"s") (Just msg) (Exts.TyCon (Exts.UnQual (Exts.Ident "CInt"))) ann) in if annArrayIsList (antAnn x) then [base, size] else [base]) ntypes aName) aName = [(antType (ntypes!!(x-1)),"a"++show x) | x <- [1..(length ntypes)]] enum = pp $ filter isAlphaNum name --(map toLower name)@@ -277,12 +284,12 @@ True -> "(" ++ dna ++ " " ++ unwords e ++")" mkPeek :: Int -> FuncP- mkPeek c dna newtpe (Constr namep ntypes) =+ mkPeek c dna newtpe (Constr namep ft ntypes) = let col = case newtpe of- True -> inner ++ [PeekReturn esc namep aName]+ True -> inner ++ [PeekReturn dbg esc namep aName modnm] False -> [PeekEntry c $ concat (zipWith (\x (c,b)->let base = PeekValue (b++"'") namep (antName x) _newptr c size = PeekValue (b++"s") namep (antName x++"_Size") _newptr "CInt"- in if annArrayIsList (antAnn x) then [base, size] else [base]) ntypes bName) ++ [PeekReturn esc namep aName]]+ in if annArrayIsList (antAnn x) then [base, size] else [base]) ntypes bName) ++ [PeekReturn dbg esc namep aName modnm]] in col where _ptr = "ptr"
WinDll/CodeGen/Lookup.hs view
@@ -18,7 +18,7 @@ import WinDll.Structs.MShow.MShow import WinDll.Structs.Structures import WinDll.Structs.Folds.HaskellSrcExts -import WinDll.Session +import WinDll.Session.Hs2lib import WinDll.Lib.Native import Data.List
+ WinDll/Debug/Alloc.xhs view
@@ -0,0 +1,138 @@+{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- These re-exported allocation functions allows us to +-- keep track of memory allocations within our program. +-- We can later analyze this to find memory leaks +-- +----------------------------------------------------------------------------- + +module WinDll.Debug.Alloc + ( alloca + , malloc + , realloc + , record + , recordM + , freeDefault + , freeUnknown + , free + ) where + +import WinDll.Debug.Records +import WinDll.Debug.Stack ( Stack, Stackable(..) ) + +import qualified Foreign.Marshal.Alloc as F +import Foreign ( Storable(..), Ptr) + +import Data.Time.Clock ( getCurrentTime, UTCTime ) +import Data.Time.Format ( formatTime ) +import System.Locale + +-- | Re-export of the Foreign.Marshal.Alloc.alloca function taking an explicit stack +alloca :: forall a b st. (Storable a, Stackable st) => st -> (Ptr a -> IO b) -> IO b +alloca stack fn = do ptr <- F.alloca (return :: Ptr a -> IO (Ptr a)) + val <- F.alloca fn + time <- getCurrentTime + let start = read (show ptr) + size = sizeOf (undefined :: a) + mem = MemAlloc { memFun = Alloc + , memStack = toStack stack + , memStart = start + , memStop = Just (start + size) + , memSize = Just size + , memTime = formatTime defaultTimeLocale "%s" time + } + writeMemAlloc mem + return val + +-- | Re-export of the Foreign.Marshal.Alloc.malloc function taking an explicit stack +malloc :: forall a st. (Storable a, Stackable st) => st -> IO (Ptr a) +malloc stack = do ptr <- F.malloc + time <- getCurrentTime + let start = read (show ptr) + size = sizeOf (undefined :: a) + mem = MemAlloc { memFun = Malloc + , memStack = toStack stack + , memStart = start + , memStop = Just (start + size) + , memSize = Just size + , memTime = formatTime defaultTimeLocale "%s" time + } + writeMemAlloc mem + return ptr + +-- | Re-export of the Foreign.Marshal.Alloc.realloc function taking an explicit stack +realloc :: forall a b st. (Storable b, Stackable st) => st -> Ptr a -> IO (Ptr b) +realloc stack ptr = do ptr' <- F.realloc ptr + time <- getCurrentTime + let start = read (show ptr) + size = sizeOf (undefined :: b) + mem = MemAlloc { memFun = ReAlloc + , memStack = toStack stack + , memStart = start + , memStop = Just (start + size) + , memSize = Just size + , memTime = formatTime defaultTimeLocale "%s" time + } + writeMemAlloc mem + return ptr' + +-- | This function record the allocation information about a Ptr we couldn't override it's allocation function for. +record :: forall a st m. (Storable a, Stackable st, Show (m a)) => st -> m a -> IO () +record stack ptr = do time <- getCurrentTime + let start = read (show ptr) + size = sizeOf (undefined :: a) + mem = MemAlloc { memFun = Record + , memStack = toStack stack + , memStart = start + , memStop = Just (start + size) + , memSize = Just size + , memTime = formatTime defaultTimeLocale "%s" time + } + writeMemAlloc mem + +-- | This function mirrors /record/ in its function. Except that the value it's given might not be a ptr value +recordM :: forall a st b. (Storable a, Stackable st) => st -> b -> (b -> IO (Ptr a)) -> IO (Ptr a) +recordM stack val mk = do ptr <- mk val + record stack ptr + return ptr + +-- | Free a ptr that is not a normal Ptr type, (e.g. ForeignPtr etc) +freeDefault :: forall a st m. (Storable a, Stackable st, Show (m a)) => st -> m a -> (m a -> IO ()) -> IO () +freeDefault stack ptr fn = do time <- getCurrentTime + let start = read (show ptr) + size = sizeOf (undefined :: a) + mem = MemFree { memStack = toStack stack + , memStart = start + , memSize = Just size + , memTime = formatTime defaultTimeLocale "%s" time + } + writeMemAlloc mem + fn ptr + +-- | Free a ptr that is not a normal Ptr type, (e.g. ForeignPtr etc), +-- however it does not record the size of the value held by the pointer. +-- as such, it has no need for the Storable requirement +freeUnknown :: forall a st m. (Stackable st, Show (m a)) => st -> m a -> (m a -> IO ()) -> IO () +freeUnknown stack ptr fn = do time <- getCurrentTime + let start = read (show ptr) + mem = MemFree { memStack = toStack stack + , memStart = start + , memSize = Nothing + , memTime = formatTime defaultTimeLocale "%s" time + } + writeMemAlloc mem + fn ptr + +-- | Re-export of the Foreign.Marshal.Alloc.free function taking an explicit stack +free :: forall a st. (Storable a, Stackable st) => st -> Ptr a -> IO () +free stack ptr = freeDefault stack ptr F.free
+ WinDll/Debug/Analyzer.hs view
@@ -0,0 +1,39 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Module to process heap requests+--+-----------------------------------------------------------------------------++module WinDll.Debug.Analyzer where++import WinDll.Debug.Records+import WinDll.Debug.Heap+import WinDll.Utils.Feedback+import WinDll.Session.Debug+import WinDll.Debug.Stack++-- | Emulate all the allocations and returned a managed Heap+emulate :: [MemAlloc] -> (Int,Int) -> Heap -> Exec Heap+emulate [] _ heap = liftIO (putStrLn "") >> return heap+emulate (m:xs) (i,t) heap = do progress _always i t 20+ case m of+ MemFree{} -> do inform _detail $ "Freeing memory from " ++ printStack (memStack m) + heap' <- removeFromHeap heap (memStart m)+ emulate xs (i + 1, t) $! heap'+ MemAlloc{} -> do inform _detail $ "Performing allocation for " ++ printStack (memStack m)+ heap' <- case memFun m of+ Malloc -> addToHeap heap (memStart m) (maybe 1 id (memSize m))+ Alloc -> addToHeap heap (memStart m) (maybe 1 id (memSize m))+ ReAlloc -> resizeHeap heap (memStart m) (maybe 1 id (memSize m))+ Other -> do inform _detail $ "Ignoring allocation at 0x" ++ asHex (memStart m)+ return heap+ Record -> addToHeap heap (memStart m) (maybe 1 id (memSize m))+ emulate xs (i + 1, t) $! heap'
+ WinDll/Debug/Exports.xhs view
@@ -0,0 +1,33 @@+{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- A module containing memory management exports that will be automatically +-- added to your file when --debug is being used. +-- +----------------------------------------------------------------------------- + +module WinDll.Debug.Exports where + +import qualified WinDll.Debug.Alloc as F ( freeUnknown ) +import qualified Foreign.Marshal.Alloc as G +import WinDll.Debug.Stack () + +import Foreign +import Foreign.Ptr + +foreign export stdcall "freeS" freeS :: Ptr () -> IO () +foreign export ccall "freeC" freeC :: Ptr () -> IO () + +freeS :: Ptr () -> IO () +freeS ptr = F.freeUnknown "[External Source]" ptr G.free + +freeC :: Ptr () -> IO () +freeC ptr = F.freeUnknown "[External Source]" ptr G.free
+ WinDll/Debug/Heap.hs view
@@ -0,0 +1,132 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- A virtual heap manipulation function+--+-----------------------------------------------------------------------------++module WinDll.Debug.Heap where++import Numeric+import Data.Char++import WinDll.Debug.Records+import WinDll.Session.Debug+import WinDll.Utils.Feedback++import Data.Function+import Data.List++type Address = Int+type Size = Int++-- | Virtual heap representation+data Heap = Blob {start :: Address + ,stop :: Address + }+ | Heap {value :: Heap+ ,next :: Heap + }+ | NoHeap+ deriving (Eq, Show)+ +asHex = \x -> showIntAtBase 16 intToDigit x ""++-- | Retreive the amount of items in the heap+sizeHeap :: Heap -> Int+sizeHeap NoHeap = 0+sizeHeap Blob{} = 1+sizeHeap heap = sizeHeap (value heap) + sizeHeap (next heap)++-- | Get all the starting addresses+getStartingAddr :: Heap -> [Address]+getStartingAddr NoHeap = []+getStartingAddr (Heap a b) = getStartingAddr a ++ getStartingAddr b+getStartingAddr x = [start x]+ +-- | Add a new address to the heap +addToHeap :: Heap -> Address -> Size -> Exec Heap+addToHeap heap st sz = do inform _detail $ "Mallocing " ++ show sz ++ " bytes starting at 0x" ++ asHex st ++ "."+ return $ insertHeap heap (Blob st (st + sz))++-- | Grow the heap at the starting address by the amount given.+-- New size is oldsize + given size+expandHeap :: Heap -> Address -> Size -> Exec Heap+expandHeap heap start sz = do inform _detail $ "Expanding 0x" ++ asHex start ++ " with " ++ show sz ++ " bytes."+ modifyHeap heap start mk+ where mk (Blob st os) = Blob st (os + sz)++-- | Shrink the heap at the starting address by the amount given.+-- New size is oldsize - given size+contractHeap :: Heap -> Address -> Size -> Exec Heap+contractHeap heap start sz = do inform _detail $ "Contracting 0x" ++ asHex start ++ " with " ++ show sz ++ " bytes."+ modifyHeap heap start mk+ where mk (Blob st os) = Blob st (os - sz)++-- | Resize the address starting at the given point to the given size+resizeHeap :: Heap -> Address -> Size -> Exec Heap+resizeHeap heap start sz = do inform _detail $ "Resizing 0x" ++ asHex start ++ " to " ++ show sz ++ " bytes."+ modifyHeap heap start mk+ where mk (Blob st os) = Blob st sz+ +-- | Merge two heaps together producing one larger heap+combineHeap :: Heap -> Heap -> Exec Heap+combineHeap hp1 hp2 = do inform _detail "Merging heaps..."+ let heap = merge hp1 hp2+ inform _detail "Merge done."+ normalizeHeap heap+ where merge NoHeap hp2 = hp2+ merge hp1 NoHeap = hp1+ merge hp1 h@Blob{} = Heap h hp1+ merge h@Blob{} hp2 = Heap h hp2 + merge (Heap v1 n1) hp2 = merge n1 (Heap v1 hp2)+ +-- | Remove an entry from the heap+removeFromHeap :: Heap -> Address -> Exec Heap+removeFromHeap heap addr = do inform _detail $ "Removing pointer 0x" ++ asHex addr ++ " from heap."+ heap <- modifyHeap heap addr (const NoHeap)+ -- normalizeHeap heap+ return heap++-- | Reduce the heap to the smallest possible heap+-- without merging bordering allocations. This might be added later+-- this function assumes the heap is sorted.+normalizeHeap :: Heap -> Exec Heap+normalizeHeap heap = let lst = flatten heap + entries = sortBy (compare `on` start) lst+ in return $ foldl' insertHeap NoHeap entries+ where flatten :: Heap -> [Heap]+ flatten b@Blob{} = [b]+ flatten NoHeap = []+ flatten (Heap a b) = flatten a ++ flatten b+ +-- | Insert an item into a sorted heap, keeping it sorted+insertHeap :: Heap -> Heap -> Heap+insertHeap NoHeap heap = heap+insertHeap heap NoHeap = heap+insertHeap hp1@Blob{} hp2@Blob{} = if start hp1 > stop hp2+ then Heap hp2 hp1+ else if start hp2 > stop hp1+ then Heap hp1 hp2+ else Blob (start hp1 `min` start hp2) (stop hp1 `max` stop hp2)+insertHeap heap1 heap2 = heap1 { next = insertHeap (next heap1) heap2 }++-- | Looks up the heap allocation starting at the given address.+-- If it's found, it's updated by applying the update function.+-- If it's not found the unmodified heap would be returned.+modifyHeap :: Heap -> Address -> (Heap -> Heap) -> Exec Heap+modifyHeap heap start f = return $ modify heap+ where modify h@(Blob st _) | st == start = f h+ modify (Heap val nxt) = let val' = modify val+ nxt' = modify nxt+ in if val' == val+ then Heap val nxt'+ else Heap val' nxt+ modify x = x
+ WinDll/Debug/Heap.hs-boot view
@@ -0,0 +1,15 @@+module WinDll.Debug.Heap where++type Address = Int+type Size = Int++-- | Virtual heap representation+data Heap = Blob {start :: Address + ,stop :: Address + }+ | Heap {value :: Heap+ ,next :: Heap + }+ | NoHeap+ +instance Show Heap where
+ WinDll/Debug/Output.hs view
@@ -0,0 +1,96 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Module to process the Memory.dump file. From loading to analysis. +-- +----------------------------------------------------------------------------- + +module WinDll.Debug.Output where + +import WinDll.Session.Debug +import WinDll.Debug.Records +import WinDll.Debug.Stack +import WinDll.Debug.Heap +import WinDll.Debug.Analyzer +import WinDll.Utils.Feedback + +import Data.Maybe +import Data.List +import Data.Function + +-- | Load and Parse files +loadAndParse :: Exec () +loadAndParse = do session <- get + let file = absPath session + inform _normal $ "Reading file '" ++ file ++ "'..." + contents <- liftIO $ readFile file + let mems = map read $ lines contents + let len = length mems + inform _normal $ "Found " ++ show len ++ " record(s)." + put $ session { memAllocs = len `seq` mems + , memAllocsLen = len + } + +data Outstanding = Outs { outCount :: Int + , outStack :: Stack + , outAddresses :: [Address] + } + +instance Show Outstanding where + show x = show (outCount x) ++ " unfreed references found originating from " ++ printStack (outStack x) + +data MemResult + = MemResult { memHeap :: Heap + , memRSize :: Int + , memOuts :: [Outstanding] + , memUnAlloc :: Int + } + deriving (Show) + +-- | Analyze the memory allocation functions +analyze :: Exec MemResult +analyze = do session <- get + heap' <- emulate (memAllocs session) (0, memAllocsLen session) (heap session) + hp <- normalizeHeap heap' + let allocs = filter isMem $ memAllocs session + isMem = \x -> case x of + MemAlloc{} -> True + _ -> False + locs = getStartingAddr hp + found = mapMaybe (flip lookupStack allocs) locs + size = sizeHeap hp + outst = size - length found + merged = groupBy ((==) `on` snd) $ sortBy (compare `on` snd) found + outdat = map (\x -> guard (not $ null x) >> (return $ Outs (length x) (snd $ head x) (map fst x))) merged + put $ session { memAllocs =[], memAllocsLen = 0, heap = hp } + return $ MemResult { memHeap = hp + , memRSize = size + , memUnAlloc = outst + , memOuts = catMaybes outdat + } + +-- | Lookup an address and return its associated stack +lookupStack :: Address -> [MemAlloc] -> Maybe (Address, Stack) +lookupStack _ [] = Nothing +lookupStack p (x:xs) | p >= memStart x && p `lt` memStop x = return (p, memStack x) + | otherwise = lookupStack p xs + +lt = \x -> maybe False id . liftM (x <=) + +-- | Show the result of the analysis +displayResults :: MemResult -> Exec () +displayResults mem = do echo $ "Found " ++ show (memRSize mem) ++ " outstanding allocation(s)." + when (memUnAlloc mem > 0) $ echo $ "Unable to resolve " ++ show (memUnAlloc mem) ++ " allocation(s)." + liftIO $ mapM_ print $ memOuts mem + when (memUnAlloc mem == 0) $ liftIO $ putStrLn "Congratulations, No memory leak(s) detected." + +-- | Discover file locations +discoverFiles :: Exec () +discoverFiles = do return ()
+ WinDll/Debug/Records.xhs view
@@ -0,0 +1,79 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Contains the structures to hold allocation information +-- used when debugging. +-- +----------------------------------------------------------------------------- + +module WinDll.Debug.Records + ( MemAlloc(..) + , Caller(..) + , fileName + , writeMemAlloc + ) where + +import WinDll.Debug.Stack ( Stack ) +import System.Directory ( doesFileExist, createDirectoryIfMissing ) +import Control.Monad ( when ) +import Control.Concurrent.MVar + +import System.FilePath +import System.IO.Unsafe + +type PtrLocation = Int -- 32bit signed integer, like the rest of hs2lib we assume x86 +type MemSize = Int + +-- | Identifier which shows which function was invoked to do allocations +data Caller = Malloc + | Alloc + | ReAlloc + | Other + | Record + deriving (Show, Read) + +-- | The allocation structure/record that is used to keep track of allocations +data MemAlloc = MemAlloc { memFun :: Caller + , memStack :: Stack + , memStart :: PtrLocation + , memStop :: Maybe PtrLocation + , memSize :: Maybe MemSize + , memTime :: String + } + | MemFree { memStack :: Stack + , memStart :: PtrLocation + , memSize :: Maybe MemSize + , memTime :: String + } + deriving (Show, Read) + +-- | The directory in which to write the results to. +directory :: String +directory = "MemDumps" + +-- | The file to write the results too +fileName :: IO String +fileName = do let path = "Memory.dump" + createDirectoryIfMissing True directory + return $ directory </> path + +-- | Synchronization variable between threads. +fileLock :: MVar Int +{-# NOINLINE fileLock #-} +fileLock = unsafePerformIO $ newMVar 0 + +-- | Write out a single allocation structure out to file. +writeMemAlloc :: MemAlloc -> IO () +writeMemAlloc mem = do takeMVar fileLock + fn <- fileName + exists <- doesFileExist fn + when (not exists) $ writeFile fn [] + appendFile fn (show mem ++ "\n") + putMVar fileLock 0
+ WinDll/Debug/Stack.xhs view
@@ -0,0 +1,102 @@+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Contains a pseudo implementation of an artificial stack. +-- This is used to print a StackTrace out and manipulate the stack. +-- +----------------------------------------------------------------------------- + +module WinDll.Debug.Stack + ( Stack() + , Stackable(..) + , FunctionName + , emptyStack + , pushStack + , topStack + , popStack + , newStack + , sizeStack + , shrinkStack + , printStack + ) where + +import System.FilePath + +import Data.Data +import Data.Typeable + +type FunctionName = String + +-- | A simple stack implementation +data Stack = Empty + | Then FunctionName Stack + | Combined Stack Stack + | Recursed Stack Stack + deriving (Typeable, Data, Eq, Show, Read, Ord) + +class Show a => Stackable a where + toStack :: a -> Stack + +instance Stackable Stack where + toStack = id + +instance Stackable String where + toStack = newStack + +-- instance Show Stack where + -- show = printStack + +-- | Pretty print a stack back out to a string +printStack :: Stack -> String +printStack Empty = [] +printStack (Then fn s) = printStack s </> ";" </> fn </> ";" +printStack (Combined s1 s2) = printStack s2 </> printStack s1 +printStack (Recursed s1 s2) = printStack s2 </> printStack s1 </> "..." + +-- | Creating an empty stack +emptyStack :: Stack +emptyStack = Empty + +-- | Create a new stack from a template +newStack :: FunctionName -> Stack +newStack fn = pushStack Empty fn + +-- | Adding an element to the top of the stack +pushStack :: Stackable st => st -> FunctionName -> Stack +pushStack = flip Then . toStack + +-- | Remove an element from the top of the stack +popStack :: Stack -> Stack +popStack Empty = error "An empty stack cannot be popped" +popStack (Then _ s) = s +popStack (Combined s1 s2) = Combined (popStack s1) s2 +popStack (Recursed s1 s2) = Recursed (popStack s1) s2 + +-- | Look at the item at the top of the stack, but does not remove it +topStack :: Stack -> Maybe FunctionName +topStack Empty = Nothing +topStack (Then fn s) = Just fn +topStack (Combined s1 s2) = topStack s1 +topStack (Recursed s1 s2) = topStack s1 + +-- | The size of the stack e.g the amount of elements inside it +sizeStack :: Stack -> Int +sizeStack Empty = 0 +sizeStack (Then _ s) = 1 + sizeStack s +sizeStack (Combined s1 s2) = sizeStack s1 + sizeStack s2 +sizeStack (Recursed s1 s2) = sizeStack s1 + sizeStack s2 + +-- | Shrinks and Compress the stack, reducing the stack to the bare minimum +-- of steps/calls needed to represent the same stack +shrinkStack :: Stack -> Stack +shrinkStack = id
WinDll/EntryPoint.hs view
@@ -21,7 +21,7 @@ module WinDll.EntryPoint where -import WinDll.Session +import WinDll.Session.Hs2lib import WinDll.Utils.Feedback import WinDll.Builder
WinDll/Identifier.hs view
@@ -14,7 +14,7 @@ -- ----------------------------------------------------------------------------- -module WinDll.Identifier where +module WinDll.Identifier where import GHC hiding (Type,DataType,NewType,Name,getName,Module) import GHC.Paths ( libdir ) @@ -32,8 +32,8 @@ import WinDll.Utils.Feedback import WinDll.Utils.Types (simplify) import WinDll.Builder -import WinDll.Parsers -import WinDll.Session +import WinDll.Parsers.Hs2lib +import WinDll.Session.Hs2lib import WinDll.Lib.Native import WinDll.Lib.Instances import WinDll.Lib.NativeMapping @@ -163,14 +163,14 @@ genCallbacksFromDatatype defs (NewType a b c d) = genCallbacksFromDatatype defs (DataType a b [c] d) genCallbacksFromDatatype defs (DataType a _ c _) = concatMap findCallbacks c where findCallbacks :: DataType -> [Callback] - findCallbacks (Constr n tys) = let values = filter (gIsFun . antType) tys - mkC rec | a==n = Callback ("CBF" ++ a ++ nm) ty (translatePartial (annWorkingSet defs) ty) _ty (ann `mappend` defs) -- ^ temporary black whole - | otherwise = Callback ("CBF" ++ a ++ n ++ nm) ty (translatePartial (annWorkingSet defs) ty) _ty (ann `mappend` defs) - where _ty = addParen (antOrigType rec) - ty = addParen (antType rec) - nm = antName rec - ann = antAnn rec - in map mkC values + findCallbacks (Constr n ft tys) = let values = filter (gIsFun . antType) tys + mkC rec | a==n = Callback ("CBF" ++ a ++ nm) ty (translatePartial (annWorkingSet defs) ty) _ty (ann `mappend` defs) -- ^ temporary black whole + | otherwise = Callback ("CBF" ++ a ++ n ++ nm) ty (translatePartial (annWorkingSet defs) ty) _ty (ann `mappend` defs) + where _ty = addParen (antOrigType rec) + ty = addParen (antType rec) + nm = antName rec + ann = antAnn rec + in map mkC values -- | Find all TyApp beginning with StablePtr and return the right sides. findStableRefs :: (Data r, Typeable r) => r -> [Stable] @@ -178,7 +178,7 @@ vals = nub $ map simplify list dats = simplify vals nms = map flattenToString dats - in [Stable ("free"++x) y | x <- nms, y <- dats] + in [Stable ("free"++x) y [] | x <- nms, y <- dats] where isRef (Exts.TyApp x y) | mshowM 2 x == "StablePtr" = True isRef _ = False @@ -186,23 +186,26 @@ -- | Generate free functions for stable ptrs found. generateFreeFuncs :: [Stable] -> [Function] generateFreeFuncs = map mkFun - where mkFun (Stable nm ty) = Function { fnName = nm - , fnArity = 1 - , fnType = mk ty - , fnAnn = mempty - , fnOrigType = mk ty - } + where mkFun (Stable nm ty modnm) + = Function { fnName = nm + , fnArity = 1 + , fnType = mk ty + , fnAnn = mempty + , fnOrigType = mk ty + } ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) mk ty = Exts.TyFun ty ctType -- | Generate free exports for stable ptrs found. generateFreeExports :: [Stable] -> [Export] generateFreeExports = map mkFun - where mkFun (Stable nm ty) = Export { exName = nm - , exAs = nm - , exType = mk ty - , exOrgType = mk ty - } + where mkFun (Stable nm ty modnm) + = Export { exName = nm + , exAs = nm + , exType = mk ty + , exOrgType = mk ty + , exModule = modnm + } ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) mk ty = Exts.TyFun ty ctType @@ -280,7 +283,10 @@ -- restriction as above. ------------------------------------------------------------------------------ mergeModules :: [WinDll.Structs.Structures.Module] -> WinDll.Structs.Structures.Module -mergeModules = mconcat +mergeModules = fiximports . mconcat + where fiximports m = m { imports = expand (imports m) 1 } + expand (('@':nm):xs) n = ("qualified " ++ nm ++ " as S" ++ show n):expand xs (n+1) + expand name _ = name -- | Find the structures needed in a module and returns the list of datatypes it needs -- to export, and the list of missing datatypes and the list of types to specialize @@ -364,7 +370,7 @@ resolve (NewType n t d tag) = resolve $ DataType n t [d] tag resolve (DataType n t xs tag) = n' : (filter check $ unwind xs) where check _type = (n' /= _type) && (_type `notElem` t) - unwind = concatMap (\(Constr _ t) -> concatMap (collectTypes . antType) t) + unwind = concatMap (\(Constr _ _ t) -> concatMap (collectTypes . antType) t) cast = (id :: Name -> TypeName) n' = cast n @@ -372,7 +378,7 @@ createList :: DataType -> [TypeTag] createList (NewType n t xs tag) = createList (DataType n t [xs] tag) createList (DataType n t xs tag) = tag : concatMap createList xs -createList (Constr _ nt) = map (create.antType) $ sanitize nt +createList (Constr _ ft nt) = map (create.antType) $ sanitize nt where sanitize = filter (not.and.map isLower.head.collectTypes.antType) create = \n -> TypeTag (mshow n) False undefined
WinDll/Lib/Instances.hs view
@@ -23,7 +23,6 @@ import WinDll.Structs.Structures import WinDll.Structs.MShow.HaskellSrcExts import WinDll.Structs.MShow.MShow -import WinDll.Parsers import Foreign import Foreign.C @@ -80,15 +79,15 @@ -- | Specializable constant for Maybe specMaybe :: DataType -specMaybe = let con = [Constr "Nothing" [] - ,Constr "Just" [AnnType "maybe_just_var1" ty noAnn ty] +specMaybe = let con = [Constr "Nothing" Normal [] + ,Constr "Just" Normal [AnnType "maybe_just_var1" ty noAnn ty "Prelude"] ] ty = Exts.TyVar (Exts.Ident "a") in DataType "Maybe" ["a"] con NoTag specEither :: DataType -specEither = let con = [Constr "Left" [AnnType "either_left_var1" tyA noAnn tyA] - ,Constr "Right" [AnnType "either_right_var1" tyB noAnn tyB] +specEither = let con = [Constr "Left" Normal [AnnType "either_left_var1" tyA noAnn tyA "Prelude"] + ,Constr "Right" Normal [AnnType "either_right_var1" tyB noAnn tyB "Prelude"] ] tyA = Exts.TyVar (Exts.Ident "a") tyB = Exts.TyVar (Exts.Ident "b") @@ -96,8 +95,8 @@ -- | Specializable constant for Located specLocated :: DataType -specLocated = let con = [Constr "L" [AnnType "located_l_var1" tyA noAnn tyA - ,AnnType "located_l_var2" tyB noAnn tyB] +specLocated = let con = [Constr "L" Normal [AnnType "located_l_var1" tyA noAnn tyA "Prelude" + ,AnnType "located_l_var2" tyB noAnn tyB "Prelude"] ] tyA = Exts.TyCon (Exts.UnQual (Exts.Ident "SrcSpan")) tyB = Exts.TyVar (Exts.Ident "e")
+ WinDll/Lib/NativeMapping.cpphs view
@@ -0,0 +1,3 @@+#undef DEBUG + +#include "NativeMapping_Base.cpphs"
− WinDll/Lib/NativeMapping.hs
@@ -1,384 +0,0 @@-{-# 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- -
+ WinDll/Lib/NativeMapping_Base.cpphs view
@@ -0,0 +1,487 @@+{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- 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 +#ifdef DEBUG +-- This module has been preprocessed to add debugging abilities to the code, including +-- an artificial stack. This combined with the methods in the debug modules should +-- allow for better memory handling. +#endif +-- +----------------------------------------------------------------------------- +#if defined(DEBUG) +module WinDll.Lib.NativeMapping_Debug where +#else +module WinDll.Lib.NativeMapping where +#endif + +import FastString +import FastTypes + +import Foreign.C +import Foreign.C.String +#if defined(DEBUG) +import Foreign hiding (free, malloc, alloca, realloc) +import Foreign.Marshal.Alloc hiding (free, malloc, alloca, realloc) +#else +import Foreign +import Foreign.Marshal.Alloc +#endif +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 +#ifdef DEBUG +import WinDll.Debug.Stack +import WinDll.Debug.Alloc +#endif + +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 +#if defined(DEBUG) + 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 (); +#else + 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 (); +#endif + +-- | 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) +#if defined(DEBUG) +#define _CONST_ const +#define _ID_ const id +#define _ST_ st +#define RECORD(file,line,name,fn) \st ptr -> record (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) ptr >> return (fn ptr) +#define RECORDM(file,line,name,fn) \st val -> recordM (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) val fn +#define FREE(file,line,name,fn) \st _ ptr -> freeDefault (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) ptr fn +#define UFREE(file,line,name,fn) \st _ ptr -> freeUnknown (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) ptr fn +#define MALLOC(file,line,name) \st -> malloc (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) +#else +#define _CONST_ +#define _ID_ id +#define _ST_ +#define RECORD(file,line,name,fn) \ptr -> return (fn ptr) +#define RECORDM(file,line,name,fn) fn +#define FREE(file,line,name,fn) \_ -> fn +#define UFREE(file,line,name,fn) \_ -> fn +#define MALLOC(file,line,name) malloc +#endif + +-- | 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 = _CONST_ (\x-> case x of + False -> 0 + True -> 1) + fromFFI = _CONST_ (\x-> case x of + 0 -> False + 1 -> True) + +-- | Convert booleans to Word8 to save space for use when using the ccall or stdcall conventions +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) + +-- | Convert booleans to Int8 to save space for use when using the ccall or stdcall conventions +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) + +-- | A StorablePtr instance +instance FFIType (StablePtr a) (StablePtr a) where -- StablePtr doesn't enforce Storable. So we can't record them. + -- fromNative = RECORD(__FILE__, __LINE__, "fromStablePtr", id) + -- toNative = RECORD(__FILE__, __LINE__, "toStablePtr" , id) + toFFI = _ID_ + fromFFI = _ID_ + freeFFI _ = _CONST_ freeStablePtr -- UFREE( __FILE__, __LINE__, "freeStablePtr", freeStablePtr) + +-- | A FunPtr instance +instance FFIType (FunPtr a) (FunPtr a) where + -- toNative = RECORD(__FILE__, __LINE__, "toFunPtr" , id) + -- fromNative = RECORD(__FILE__, __LINE__, "fromFunPtr" , id) + toFFI = _ID_ + fromFFI = _ID_ + freeFFI _ = _CONST_ freeHaskellFunPtr -- UFREE( __FILE__, __LINE__, "freeHaskellFunPtr", freeHaskellFunPtr) + +-- | Tranform functions to and from the correct types +-- TODO: Update this variant to use the impure variants, This will be an issue.. +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)) + +-- | I decided to use a CAString because on windows this gives me a constant 16 value +instance FFIType String CWString where + toNative = RECORDM(__FILE__, __LINE__, "newCWString" , newCWString) + fromNative _ST_ ptr = (RECORD( __FILE__, __LINE__, "peekCWString", id)) _ST_ ptr + >> peekCWString ptr + >>= \str -> freeFFI _ST_ "" ptr + >> return str + freeFFI = FREE( __FILE__, __LINE__, "freeCWString", F.free) + +-- | Intermediate conversion instance for storing values of arrays +instance (Storable a, FFIType b a) => FFIType [b] (Ptr a) where + toNative _ST_ = (RECORDM(__FILE__, __LINE__, "newArray", newArray)) _ST_ . map (toFFI _ST_) + fromList _ST_ x = fmap (map (fromFFI _ST_)) . (RECORD(__FILE__, __LINE__, "peekArray", id) >>= peekArray (fromFFI _ST_ x)) _ST_ + +-- | Another simple identity instance, I really need to get that overlapping instances +-- looked at. +instance FFIType CWchar CWchar where + fromFFI = _ID_ + toFFI = _ID_ + +-- | Another simple identity instance, I really need to get that overlapping instances +-- looked at. +instance FFIType CWString CWString where + fromFFI = _ID_ + toFFI = _ID_ + +-- | Another simple identity instance, I really need to get that overlapping instances +-- looked at. +instance FFIType CInt CInt where + toFFI = _ID_ + fromFFI = _ID_ + +-- | Another simple identity instance, I really need to get that overlapping instances +-- looked at. +instance FFIType CDouble CDouble where + toFFI = _ID_ + fromFFI = _ID_ + +-- | Another simple identity 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 _ST_ = toFFI _ST_.unpackFS + fromFFI _ST_ = mkFastString.fromFFI _ST_ + +-- | Fix integers from the machine dependend values to fixed 32bit values +instance FFIType Int CInt where + toFFI = _CONST_ fromIntegral + fromFFI = _CONST_ 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 = _CONST_ realToFrac + fromFFI = _CONST_ realToFrac + +-- | Any class implementing Storable has implemented enough to be considered a FFIType +instance Storable a => FFIType a (Ptr a) where + toNative = RECORDM(__FILE__, __LINE__, "new", new) + fromNative = RECORD( __FILE__, __LINE__, "peek", id) >>= peek + freeFFI = FREE( __FILE__, __LINE__, "free", F.free) + +-- | Cover lists to array convertion IF the type is also an FFI type +instance Storable a => FFIType [a] (Ptr a) where + toNative = RECORDM(__FILE__, __LINE__, "newArray", newArray) --fmap castPtr . new -- newArray +#ifdef DEBUG + fromList st ic ptr = (RECORD( __FILE__, __LINE__, "peek", id)) st ptr >> peekArray (fromFFI st ic) ptr --const (peek . castPtr) --peekArray +#else + fromList = peekArray . fromFFI --const (peek . castPtr) --peekArray +#endif + freeFFI = FREE( __FILE__, __LINE__, "freeArray", F.free) + -- | 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 +#ifdef DEBUG + 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 <- (MALLOC(__FILE__, __LINE__, "malloc")) st + lst <- fn ptr + ln <- peek ptr + val <- fromList st ln lst + (FREE(__FILE__, __LINE__, "freePtr", F.free)) st undefined ptr + (FREE(__FILE__, __LINE__, "freeLst", F.free)) st undefined lst + return $ val +#else + 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 +#endif + +-- | 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 +#ifdef DEBUG + poke ptr value = do newptr <- (RECORDM(__FILE__, __LINE__, "newArray", newArray)) emptyStack value +#else + poke ptr value = do newptr <- newArray value +#endif + copyArray (castPtr ptr) newptr (length value) + peekElemOff ptr c = do val <- peekArray c (castPtr ptr) +#ifdef DEBUG + (FREE(__FILE__, __LINE__, "freeArray", F.free)) emptyStack undefined ptr +#else + F.free ptr +#endif + return val + +-- | Convertion instance for Integer types to CLLongs (long long) +instance (Num a,Integral a) => FFIType Integer a where + toFFI = _CONST_ fromInteger + fromFFI = _CONST_ toInteger + +-- | Instance for Functor classes +instance (Functor f, FFIType a b) => FFIType (f a) (f b) where + toFFI _ST_ = fmap (toFFI _ST_) + fromFFI _ST_ = fmap (fromFFI _ST_) + +-- -- | 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 = _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 [] = [] + +-- | 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 + +
+ WinDll/Lib/NativeMapping_Debug.cpphs view
@@ -0,0 +1,3 @@+#define DEBUG 1 + +#include "NativeMapping_Base.cpphs"
− WinDll/Lib/Tuples.hs
@@ -1,637 +0,0 @@-{-# INCLUDE "Tuples.h" #-} -{-# LINE 1 ".\Tuples.hsc" #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LINE 2 ".\Tuples.hsc" #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ForeignFunctionInterface #-} - ------------------------------------------------------------------------------ --- | --- Module : Windll --- Copyright : (c) Tamar Christina 2009 - 2010 --- License : BSD3 --- --- Maintainer : tamar@zhox.com --- Stability : experimental --- Portability : portable --- --- Module containing definitions for tuples, since those can't be automatically --- translated. We This file contains predefined mappings of tuples till 8-tuples. --- If you need more you need to unfortunately add these yourself --- ------------------------------------------------------------------------------ - -module WinDll.Lib.Tuples where - -import WinDll.Lib.NativeMapping - -import Foreign -import Foreign.C -import Foreign.Ptr -import Foreign.Marshal.Alloc -import Foreign.Marshal.Utils - -import Control.Monad -import Control.Monad.Instances - - -{-# LINE 36 ".\Tuples.hsc" #-} - - -{-# LINE 38 ".\Tuples.hsc" #-} - --- * The datatypes to replace the tupples with - -data Tuple2 a b = Tuple2 a b -data Tuple3 a b c = Tuple3 a b c -data Tuple4 a b c d = Tuple4 a b c d -data Tuple5 a b c d e = Tuple5 a b c d e -data Tuple6 a b c d e f = Tuple6 a b c d e f -data Tuple7 a b c d e f g = Tuple7 a b c d e f g -data Tuple8 a b c d e f g h = Tuple8 a b c d e f g h - --- * Type namings - -type Tuple2Ptr a b = Ptr (Tuple2 a b) -type Tuple3Ptr a b c = Ptr (Tuple3 a b c) -type Tuple4Ptr a b c d = Ptr (Tuple4 a b c d) -type Tuple5Ptr a b c d e = Ptr (Tuple5 a b c d e) -type Tuple6Ptr a b c d e f = Ptr (Tuple6 a b c d e f) -type Tuple7Ptr a b c d e f g = Ptr (Tuple7 a b c d e f g) -type Tuple8Ptr a b c d e f g h = Ptr (Tuple8 a b c d e f g h) - --- * Functor instances so that these new tuple types can --- fit into the functor instance of the FFIType class. -instance Storable a => Functor (Tuple2 a) where - fmap f (Tuple2 a b) = Tuple2 a (f b) - -instance Storable a => Functor (Tuple3 a b) where - fmap f (Tuple3 a b c) = Tuple3 a b (f c) - -instance Storable a => Functor (Tuple4 a b c) where - fmap f (Tuple4 a b c d) = Tuple4 a b c (f d) - -instance Storable a => Functor (Tuple5 a b c d) where - fmap f (Tuple5 a b c d e) = Tuple5 a b c d (f e) - -instance Storable a => Functor (Tuple6 a b c d e) where - fmap f (Tuple6 a b c d e f') = Tuple6 a b c d e (f f') - -instance Storable a => Functor (Tuple7 a b c d e f) where - fmap f (Tuple7 a b c d e f' g) = Tuple7 a b c d e f' (f g) - -instance Storable a => Functor (Tuple8 a b c d e f g) where - fmap f (Tuple8 a b c d e f' g h) = Tuple8 a b c d e f' g (f h) - --- * The isomorphic type conversions - -instance (FFIType a b,FFIType c d) => FFIType (a,c) - (Tuple2 b d) where - toFFI (a,b) = (Tuple2 (toFFI a) (toFFI b)) - fromFFI (Tuple2 a b) = (fromFFI a, fromFFI b) - -instance (FFIType a b,FFIType c d - ,FFIType e f) => FFIType (a,c,e) - (Tuple3 b d f) where - toFFI (a,b,c) = (Tuple3 (toFFI a) (toFFI b) (toFFI c)) - fromFFI (Tuple3 a b c) = (fromFFI a, fromFFI b, fromFFI c) - -instance (FFIType a b,FFIType c d - ,FFIType e f,FFIType g h) => FFIType (a,c,e,g) - (Tuple4 b d f h) where - toFFI (a,b,c,d) = (Tuple4 (toFFI a) (toFFI b) (toFFI c) (toFFI d)) - fromFFI (Tuple4 a b c d) = (fromFFI a, fromFFI b, fromFFI c, fromFFI d) - -instance (FFIType a b,FFIType c d - ,FFIType e f,FFIType g h - ,FFIType i j) => FFIType (a,c,e,g,i) - (Tuple5 b d f h j) where - toFFI (a,b,c,d,e) = (Tuple5 (toFFI a) (toFFI b) (toFFI c) (toFFI d) - (toFFI e)) - fromFFI (Tuple5 a b c d e) = (fromFFI a, fromFFI b, fromFFI c, fromFFI d - ,fromFFI e) - -instance (FFIType a b,FFIType c d - ,FFIType e f,FFIType g h - ,FFIType i j,FFIType k l) => FFIType (a,c,e,g,i,k) (Tuple6 b d f h j l) where - toFFI (a,b,c,d,e,f) = (Tuple6 (toFFI a) (toFFI b) (toFFI c) (toFFI d) - (toFFI e) (toFFI f)) - fromFFI (Tuple6 a b c d e f) = (fromFFI a, fromFFI b, fromFFI c, fromFFI d - ,fromFFI e, fromFFI f) - -instance (FFIType a b,FFIType c d - ,FFIType e f,FFIType g h - ,FFIType i j,FFIType k l - ,FFIType m n) => FFIType (a,c,e,g,i,k,m) - (Tuple7 b d f h j l n) where - toFFI (a,b,c,d,e,f,g) = (Tuple7 (toFFI a) (toFFI b) (toFFI c) (toFFI d) - (toFFI e) (toFFI f) (toFFI g)) - fromFFI (Tuple7 a b c d e f g) = (fromFFI a, fromFFI b, fromFFI c, fromFFI d - ,fromFFI e, fromFFI f, fromFFI g) - -instance (FFIType a b,FFIType c d - ,FFIType e f,FFIType g h - ,FFIType i j,FFIType k l - ,FFIType m n,FFIType o p) => FFIType (a,c,e,g,i,k,m,o) - (Tuple8 b d f h j l n p) where - toFFI (a,b,c,d,e,f,g,h) = (Tuple8 (toFFI a) (toFFI b) (toFFI c) (toFFI d) - (toFFI e) (toFFI f) (toFFI g) (toFFI h)) - fromFFI (Tuple8 a b c d e f g h) = (fromFFI a, fromFFI b, fromFFI c, fromFFI d - ,fromFFI e, fromFFI f, fromFFI g, fromFFI h) - - -instance (FFIType a b,FFIType c d - ,Storable b, Storable d) => FFIType (a,c) - (Tuple2Ptr b d) where - toNative x = new (toFFI x) - fromNative x = fmap fromFFI (peek x) - -instance (FFIType a b,FFIType c d - ,FFIType e f,Storable b - ,Storable d, Storable f) => FFIType (a,c,e) - (Tuple3Ptr b d f) where - toNative x = new (toFFI x) - fromNative x = fmap fromFFI (peek x) - -instance (FFIType a b,FFIType c d - ,FFIType e f,FFIType g h - ,Storable b,Storable d - ,Storable f,Storable h) => FFIType (a,c,e,g) - (Tuple4Ptr b d f h) where - toNative x = new (toFFI x) - fromNative x = fmap fromFFI (peek x) - -instance (FFIType a b,FFIType c d - ,FFIType e f,FFIType g h - ,FFIType i j,Storable j - ,Storable b,Storable d - ,Storable f,Storable h) => FFIType (a,c,e,g,i) - (Tuple5Ptr b d f h j) where - toNative x = new (toFFI x) - fromNative x = fmap fromFFI (peek x) - -instance (FFIType a b,FFIType c d - ,FFIType e f,FFIType g h - ,FFIType i j,FFIType k l - ,Storable j,Storable l - ,Storable b,Storable d - ,Storable f,Storable h) => FFIType (a,c,e,g,i,k) - (Tuple6Ptr b d f h j l) where - toNative x = new (toFFI x) - fromNative x = fmap fromFFI (peek x) - -instance (FFIType a b,FFIType c d - ,FFIType e f,FFIType g h - ,FFIType i j,FFIType k l - ,FFIType m n,Storable n - ,Storable j,Storable l - ,Storable b,Storable d - ,Storable f,Storable h) => FFIType (a,c,e,g,i,k,m) - (Tuple7Ptr b d f h j l n) where - toNative x = new (toFFI x) - fromNative x = fmap fromFFI (peek x) - -instance (FFIType a b,FFIType c d - ,FFIType e f,FFIType g h - ,FFIType i j,FFIType k l - ,FFIType m n,FFIType o p - ,Storable n,Storable p - ,Storable j,Storable l - ,Storable b,Storable d - ,Storable f,Storable h) => FFIType (a,c,e,g,i,k,m,o) - (Tuple8Ptr b d f h j l n p) where - toNative x = new (toFFI x) - fromNative x = fmap fromFFI (peek x) - --- * Storage instances - -instance (Storable a, Storable b) => Storable (Tuple2 a b) where - sizeOf _ = (8) -{-# LINE 206 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 207 ".\Tuples.hsc" #-} - - poke ptr (Tuple2 a1 a2) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 210 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 211 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 213 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 214 ".\Tuples.hsc" #-} - return $ (Tuple2 a1' a2') - -instance (Storable a, Storable b, Storable c) => Storable (Tuple3 a b c) where - sizeOf _ = (12) -{-# LINE 218 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 219 ".\Tuples.hsc" #-} - - poke ptr (Tuple3 a1 a2 a3) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 222 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 223 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 224 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 226 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 227 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 228 ".\Tuples.hsc" #-} - return $ (Tuple3 a1' a2' a3') - - -instance (Storable a, Storable b, Storable c, Storable d) => Storable (Tuple4 a b c d) where - sizeOf _ = (16) -{-# LINE 233 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 234 ".\Tuples.hsc" #-} - - poke ptr (Tuple4 a1 a2 a3 a4) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 237 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 238 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 239 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr a4 -{-# LINE 240 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 242 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 243 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 244 ".\Tuples.hsc" #-} - a4' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr -{-# LINE 245 ".\Tuples.hsc" #-} - return $ (Tuple4 a1' a2' a3' a4') - - -instance (Storable a, Storable b, Storable c, Storable d, Storable e) => Storable (Tuple5 a b c d e) where - sizeOf _ = (20) -{-# LINE 250 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 251 ".\Tuples.hsc" #-} - - poke ptr (Tuple5 a1 a2 a3 a4 a5) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 254 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 255 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 256 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr a4 -{-# LINE 257 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr a5 -{-# LINE 258 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 260 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 261 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 262 ".\Tuples.hsc" #-} - a4' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr -{-# LINE 263 ".\Tuples.hsc" #-} - a5' <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr -{-# LINE 264 ".\Tuples.hsc" #-} - return $ (Tuple5 a1' a2' a3' a4' a5') - - -instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f) => Storable (Tuple6 a b c d e f) where - sizeOf _ = (24) -{-# LINE 269 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 270 ".\Tuples.hsc" #-} - - poke ptr (Tuple6 a1 a2 a3 a4 a5 a6) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 273 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 274 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 275 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr a4 -{-# LINE 276 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr a5 -{-# LINE 277 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr a6 -{-# LINE 278 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 280 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 281 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 282 ".\Tuples.hsc" #-} - a4' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr -{-# LINE 283 ".\Tuples.hsc" #-} - a5' <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr -{-# LINE 284 ".\Tuples.hsc" #-} - a6' <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) ptr -{-# LINE 285 ".\Tuples.hsc" #-} - return $ (Tuple6 a1' a2' a3' a4' a5' a6') - - -instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => Storable (Tuple7 a b c d e f g) where - sizeOf _ = (28) -{-# LINE 290 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 291 ".\Tuples.hsc" #-} - - poke ptr (Tuple7 a1 a2 a3 a4 a5 a6 a7) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 294 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 295 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 296 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr a4 -{-# LINE 297 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr a5 -{-# LINE 298 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr a6 -{-# LINE 299 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr a7 -{-# LINE 300 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 302 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 303 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 304 ".\Tuples.hsc" #-} - a4' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr -{-# LINE 305 ".\Tuples.hsc" #-} - a5' <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr -{-# LINE 306 ".\Tuples.hsc" #-} - a6' <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) ptr -{-# LINE 307 ".\Tuples.hsc" #-} - a7' <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr -{-# LINE 308 ".\Tuples.hsc" #-} - return $ (Tuple7 a1' a2' a3' a4' a5' a6' a7') - - -instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g, Storable h) => Storable (Tuple8 a b c d e f g h) where - sizeOf _ = (32) -{-# LINE 313 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 314 ".\Tuples.hsc" #-} - - poke ptr (Tuple8 a1 a2 a3 a4 a5 a6 a7 a8) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 317 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 318 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 319 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr a4 -{-# LINE 320 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr a5 -{-# LINE 321 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr a6 -{-# LINE 322 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr a7 -{-# LINE 323 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) ptr a8 -{-# LINE 324 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 326 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 327 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 328 ".\Tuples.hsc" #-} - a4' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr -{-# LINE 329 ".\Tuples.hsc" #-} - a5' <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr -{-# LINE 330 ".\Tuples.hsc" #-} - a6' <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) ptr -{-# LINE 331 ".\Tuples.hsc" #-} - a7' <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr -{-# LINE 332 ".\Tuples.hsc" #-} - a8' <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) ptr -{-# LINE 333 ".\Tuples.hsc" #-} - return $ (Tuple8 a1' a2' a3' a4' a5' a6' a7' a8') - -instance (Storable a, Storable b) => Storable (a, b) where - sizeOf _ = (8) -{-# LINE 337 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 338 ".\Tuples.hsc" #-} - - poke ptr (a1, a2) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 341 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 342 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 344 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 345 ".\Tuples.hsc" #-} - return $ (a1', a2') - -instance (Storable a, Storable b, Storable c) => Storable (a, b, c) where - sizeOf _ = (12) -{-# LINE 349 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 350 ".\Tuples.hsc" #-} - - poke ptr (a1, a2, a3) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 353 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 354 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 355 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 357 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 358 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 359 ".\Tuples.hsc" #-} - return $ (a1', a2', a3') - - -instance (Storable a, Storable b, Storable c, Storable d) => Storable (a, b, c, d) where - sizeOf _ = (16) -{-# LINE 364 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 365 ".\Tuples.hsc" #-} - - poke ptr (a1, a2, a3, a4) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 368 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 369 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 370 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr a4 -{-# LINE 371 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 373 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 374 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 375 ".\Tuples.hsc" #-} - a4' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr -{-# LINE 376 ".\Tuples.hsc" #-} - return $ (a1', a2', a3', a4') - - -instance (Storable a, Storable b, Storable c, Storable d, Storable e) => Storable (a, b, c, d, e) where - sizeOf _ = (20) -{-# LINE 381 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 382 ".\Tuples.hsc" #-} - - poke ptr (a1, a2, a3, a4, a5) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 385 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 386 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 387 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr a4 -{-# LINE 388 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr a5 -{-# LINE 389 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 391 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 392 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 393 ".\Tuples.hsc" #-} - a4' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr -{-# LINE 394 ".\Tuples.hsc" #-} - a5' <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr -{-# LINE 395 ".\Tuples.hsc" #-} - return $ (a1', a2', a3', a4', a5') - - -instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f) => Storable (a, b, c, d, e, f) where - sizeOf _ = (24) -{-# LINE 400 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 401 ".\Tuples.hsc" #-} - - poke ptr (a1, a2, a3, a4, a5, a6) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 404 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 405 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 406 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr a4 -{-# LINE 407 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr a5 -{-# LINE 408 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr a6 -{-# LINE 409 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 411 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 412 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 413 ".\Tuples.hsc" #-} - a4' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr -{-# LINE 414 ".\Tuples.hsc" #-} - a5' <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr -{-# LINE 415 ".\Tuples.hsc" #-} - a6' <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) ptr -{-# LINE 416 ".\Tuples.hsc" #-} - return $ (a1', a2', a3', a4', a5', a6') - - -instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => Storable (a, b, c, d, e, f, g) where - sizeOf _ = (28) -{-# LINE 421 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 422 ".\Tuples.hsc" #-} - - poke ptr (a1, a2, a3, a4, a5, a6, a7) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 425 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 426 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 427 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr a4 -{-# LINE 428 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr a5 -{-# LINE 429 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr a6 -{-# LINE 430 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr a7 -{-# LINE 431 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 433 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 434 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 435 ".\Tuples.hsc" #-} - a4' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr -{-# LINE 436 ".\Tuples.hsc" #-} - a5' <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr -{-# LINE 437 ".\Tuples.hsc" #-} - a6' <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) ptr -{-# LINE 438 ".\Tuples.hsc" #-} - a7' <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr -{-# LINE 439 ".\Tuples.hsc" #-} - return $ (a1', a2', a3', a4', a5', a6', a7') - - -instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g, Storable h) => Storable (a, b, c, d, e, f, g, h) where - sizeOf _ = (32) -{-# LINE 444 ".\Tuples.hsc" #-} - alignment _ = 4 -{-# LINE 445 ".\Tuples.hsc" #-} - - poke ptr (a1, a2, a3, a4, a5, a6, a7, a8) = do - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a1 -{-# LINE 448 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) ptr a2 -{-# LINE 449 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr a3 -{-# LINE 450 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr a4 -{-# LINE 451 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr a5 -{-# LINE 452 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr a6 -{-# LINE 453 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr a7 -{-# LINE 454 ".\Tuples.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) ptr a8 -{-# LINE 455 ".\Tuples.hsc" #-} - peek ptr = do - a1' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 457 ".\Tuples.hsc" #-} - a2' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 458 ".\Tuples.hsc" #-} - a3' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 459 ".\Tuples.hsc" #-} - a4' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr -{-# LINE 460 ".\Tuples.hsc" #-} - a5' <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr -{-# LINE 461 ".\Tuples.hsc" #-} - a6' <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) ptr -{-# LINE 462 ".\Tuples.hsc" #-} - a7' <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr -{-# LINE 463 ".\Tuples.hsc" #-} - a8' <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) ptr -{-# LINE 464 ".\Tuples.hsc" #-} - return $ (a1', a2', a3', a4', a5', a6', a7', a8')
− WinDll/Lib/Tuples.hsc
@@ -1,464 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ForeignFunctionInterface #-}---------------------------------------------------------------------------------- |--- Module : Windll--- Copyright : (c) Tamar Christina 2009 - 2010--- License : BSD3--- --- Maintainer : tamar@zhox.com--- Stability : experimental--- Portability : portable------ Module containing definitions for tuples, since those can't be automatically--- translated. We This file contains predefined mappings of tuples till 8-tuples.--- If you need more you need to unfortunately add these yourself-----------------------------------------------------------------------------------module WinDll.Lib.Tuples where--import WinDll.Lib.NativeMapping--import Foreign-import Foreign.C-import Foreign.Ptr-import Foreign.Marshal.Alloc-import Foreign.Marshal.Utils--import Control.Monad-import Control.Monad.Instances--#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)--#include "Tuples.h"---- * The datatypes to replace the tupples with--data Tuple2 a b = Tuple2 a b-data Tuple3 a b c = Tuple3 a b c-data Tuple4 a b c d = Tuple4 a b c d-data Tuple5 a b c d e = Tuple5 a b c d e-data Tuple6 a b c d e f = Tuple6 a b c d e f-data Tuple7 a b c d e f g = Tuple7 a b c d e f g-data Tuple8 a b c d e f g h = Tuple8 a b c d e f g h---- * Type namings--type Tuple2Ptr a b = Ptr (Tuple2 a b)-type Tuple3Ptr a b c = Ptr (Tuple3 a b c)-type Tuple4Ptr a b c d = Ptr (Tuple4 a b c d)-type Tuple5Ptr a b c d e = Ptr (Tuple5 a b c d e)-type Tuple6Ptr a b c d e f = Ptr (Tuple6 a b c d e f)-type Tuple7Ptr a b c d e f g = Ptr (Tuple7 a b c d e f g)-type Tuple8Ptr a b c d e f g h = Ptr (Tuple8 a b c d e f g h)---- * Functor instances so that these new tuple types can--- fit into the functor instance of the FFIType class.-instance Storable a => Functor (Tuple2 a) where- fmap f (Tuple2 a b) = Tuple2 a (f b)- -instance Storable a => Functor (Tuple3 a b) where- fmap f (Tuple3 a b c) = Tuple3 a b (f c)- -instance Storable a => Functor (Tuple4 a b c) where- fmap f (Tuple4 a b c d) = Tuple4 a b c (f d)- -instance Storable a => Functor (Tuple5 a b c d) where- fmap f (Tuple5 a b c d e) = Tuple5 a b c d (f e)- -instance Storable a => Functor (Tuple6 a b c d e) where- fmap f (Tuple6 a b c d e f') = Tuple6 a b c d e (f f')- -instance Storable a => Functor (Tuple7 a b c d e f) where- fmap f (Tuple7 a b c d e f' g) = Tuple7 a b c d e f' (f g)- -instance Storable a => Functor (Tuple8 a b c d e f g) where- fmap f (Tuple8 a b c d e f' g h) = Tuple8 a b c d e f' g (f h)---- * The isomorphic type conversions--instance (FFIType a b,FFIType c d) => FFIType (a,c) - (Tuple2 b d) where- toFFI (a,b) = (Tuple2 (toFFI a) (toFFI b))- fromFFI (Tuple2 a b) = (fromFFI a, fromFFI b) - -instance (FFIType a b,FFIType c d- ,FFIType e f) => FFIType (a,c,e) - (Tuple3 b d f) where- toFFI (a,b,c) = (Tuple3 (toFFI a) (toFFI b) (toFFI c))- fromFFI (Tuple3 a b c) = (fromFFI a, fromFFI b, fromFFI c)- -instance (FFIType a b,FFIType c d- ,FFIType e f,FFIType g h) => FFIType (a,c,e,g) - (Tuple4 b d f h) where- toFFI (a,b,c,d) = (Tuple4 (toFFI a) (toFFI b) (toFFI c) (toFFI d))- fromFFI (Tuple4 a b c d) = (fromFFI a, fromFFI b, fromFFI c, fromFFI d)- -instance (FFIType a b,FFIType c d- ,FFIType e f,FFIType g h- ,FFIType i j) => FFIType (a,c,e,g,i) - (Tuple5 b d f h j) where- toFFI (a,b,c,d,e) = (Tuple5 (toFFI a) (toFFI b) (toFFI c) (toFFI d) - (toFFI e))- fromFFI (Tuple5 a b c d e) = (fromFFI a, fromFFI b, fromFFI c, fromFFI d- ,fromFFI e)- -instance (FFIType a b,FFIType c d- ,FFIType e f,FFIType g h- ,FFIType i j,FFIType k l) => FFIType (a,c,e,g,i,k) (Tuple6 b d f h j l) where- toFFI (a,b,c,d,e,f) = (Tuple6 (toFFI a) (toFFI b) (toFFI c) (toFFI d) - (toFFI e) (toFFI f))- fromFFI (Tuple6 a b c d e f) = (fromFFI a, fromFFI b, fromFFI c, fromFFI d- ,fromFFI e, fromFFI f)- -instance (FFIType a b,FFIType c d- ,FFIType e f,FFIType g h- ,FFIType i j,FFIType k l- ,FFIType m n) => FFIType (a,c,e,g,i,k,m) - (Tuple7 b d f h j l n) where- toFFI (a,b,c,d,e,f,g) = (Tuple7 (toFFI a) (toFFI b) (toFFI c) (toFFI d) - (toFFI e) (toFFI f) (toFFI g))- fromFFI (Tuple7 a b c d e f g) = (fromFFI a, fromFFI b, fromFFI c, fromFFI d- ,fromFFI e, fromFFI f, fromFFI g)- -instance (FFIType a b,FFIType c d- ,FFIType e f,FFIType g h- ,FFIType i j,FFIType k l- ,FFIType m n,FFIType o p) => FFIType (a,c,e,g,i,k,m,o) - (Tuple8 b d f h j l n p) where- toFFI (a,b,c,d,e,f,g,h) = (Tuple8 (toFFI a) (toFFI b) (toFFI c) (toFFI d) - (toFFI e) (toFFI f) (toFFI g) (toFFI h))- fromFFI (Tuple8 a b c d e f g h) = (fromFFI a, fromFFI b, fromFFI c, fromFFI d- ,fromFFI e, fromFFI f, fromFFI g, fromFFI h)---instance (FFIType a b,FFIType c d- ,Storable b, Storable d) => FFIType (a,c) - (Tuple2Ptr b d) where- toNative x = new (toFFI x)- fromNative x = fmap fromFFI (peek x)- -instance (FFIType a b,FFIType c d- ,FFIType e f,Storable b- ,Storable d, Storable f) => FFIType (a,c,e) - (Tuple3Ptr b d f) where- toNative x = new (toFFI x)- fromNative x = fmap fromFFI (peek x)- -instance (FFIType a b,FFIType c d- ,FFIType e f,FFIType g h- ,Storable b,Storable d- ,Storable f,Storable h) => FFIType (a,c,e,g) - (Tuple4Ptr b d f h) where- toNative x = new (toFFI x)- fromNative x = fmap fromFFI (peek x)- -instance (FFIType a b,FFIType c d- ,FFIType e f,FFIType g h- ,FFIType i j,Storable j- ,Storable b,Storable d- ,Storable f,Storable h) => FFIType (a,c,e,g,i) - (Tuple5Ptr b d f h j) where- toNative x = new (toFFI x)- fromNative x = fmap fromFFI (peek x)- -instance (FFIType a b,FFIType c d- ,FFIType e f,FFIType g h- ,FFIType i j,FFIType k l- ,Storable j,Storable l- ,Storable b,Storable d- ,Storable f,Storable h) => FFIType (a,c,e,g,i,k) - (Tuple6Ptr b d f h j l) where- toNative x = new (toFFI x)- fromNative x = fmap fromFFI (peek x)- -instance (FFIType a b,FFIType c d- ,FFIType e f,FFIType g h- ,FFIType i j,FFIType k l- ,FFIType m n,Storable n- ,Storable j,Storable l- ,Storable b,Storable d- ,Storable f,Storable h) => FFIType (a,c,e,g,i,k,m) - (Tuple7Ptr b d f h j l n) where- toNative x = new (toFFI x)- fromNative x = fmap fromFFI (peek x)- -instance (FFIType a b,FFIType c d- ,FFIType e f,FFIType g h- ,FFIType i j,FFIType k l- ,FFIType m n,FFIType o p- ,Storable n,Storable p- ,Storable j,Storable l- ,Storable b,Storable d- ,Storable f,Storable h) => FFIType (a,c,e,g,i,k,m,o) - (Tuple8Ptr b d f h j l n p) where- toNative x = new (toFFI x)- fromNative x = fmap fromFFI (peek x)- --- * Storage instances--instance (Storable a, Storable b) => Storable (Tuple2 a b) where- sizeOf _ = #size Tuple2_t- alignment _ = #alignment Tuple2_t- - poke ptr (Tuple2 a1 a2) = do- (#poke Tuple2_t, tuple2_var1) ptr a1- (#poke Tuple2_t, tuple2_var2) ptr a2- peek ptr = do- a1' <- (#peek Tuple2_t, tuple2_var1) ptr- a2' <- (#peek Tuple2_t, tuple2_var2) ptr- return $ (Tuple2 a1' a2')- -instance (Storable a, Storable b, Storable c) => Storable (Tuple3 a b c) where- sizeOf _ = #size Tuple3_t- alignment _ = #alignment Tuple3_t- - poke ptr (Tuple3 a1 a2 a3) = do- (#poke Tuple3_t, tuple3_var1) ptr a1- (#poke Tuple3_t, tuple3_var2) ptr a2- (#poke Tuple3_t, tuple3_var3) ptr a3- peek ptr = do- a1' <- (#peek Tuple3_t, tuple3_var1) ptr- a2' <- (#peek Tuple3_t, tuple3_var2) ptr- a3' <- (#peek Tuple3_t, tuple3_var3) ptr- return $ (Tuple3 a1' a2' a3')---instance (Storable a, Storable b, Storable c, Storable d) => Storable (Tuple4 a b c d) where- sizeOf _ = #size Tuple4_t- alignment _ = #alignment Tuple4_t- - poke ptr (Tuple4 a1 a2 a3 a4) = do- (#poke Tuple4_t, tuple4_var1) ptr a1- (#poke Tuple4_t, tuple4_var2) ptr a2- (#poke Tuple4_t, tuple4_var3) ptr a3- (#poke Tuple4_t, tuple4_var4) ptr a4- peek ptr = do- a1' <- (#peek Tuple4_t, tuple4_var1) ptr- a2' <- (#peek Tuple4_t, tuple4_var2) ptr- a3' <- (#peek Tuple4_t, tuple4_var3) ptr- a4' <- (#peek Tuple4_t, tuple4_var4) ptr- return $ (Tuple4 a1' a2' a3' a4')---instance (Storable a, Storable b, Storable c, Storable d, Storable e) => Storable (Tuple5 a b c d e) where- sizeOf _ = #size Tuple5_t- alignment _ = #alignment Tuple5_t- - poke ptr (Tuple5 a1 a2 a3 a4 a5) = do- (#poke Tuple5_t, tuple5_var1) ptr a1- (#poke Tuple5_t, tuple5_var2) ptr a2- (#poke Tuple5_t, tuple5_var3) ptr a3- (#poke Tuple5_t, tuple5_var4) ptr a4- (#poke Tuple5_t, tuple5_var5) ptr a5- peek ptr = do- a1' <- (#peek Tuple5_t, tuple5_var1) ptr- a2' <- (#peek Tuple5_t, tuple5_var2) ptr- a3' <- (#peek Tuple5_t, tuple5_var3) ptr- a4' <- (#peek Tuple5_t, tuple5_var4) ptr- a5' <- (#peek Tuple5_t, tuple5_var5) ptr- return $ (Tuple5 a1' a2' a3' a4' a5')---instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f) => Storable (Tuple6 a b c d e f) where- sizeOf _ = #size Tuple6_t- alignment _ = #alignment Tuple6_t- - poke ptr (Tuple6 a1 a2 a3 a4 a5 a6) = do- (#poke Tuple6_t, tuple6_var1) ptr a1- (#poke Tuple6_t, tuple6_var2) ptr a2- (#poke Tuple6_t, tuple6_var3) ptr a3- (#poke Tuple6_t, tuple6_var4) ptr a4- (#poke Tuple6_t, tuple6_var5) ptr a5- (#poke Tuple6_t, tuple6_var6) ptr a6- peek ptr = do- a1' <- (#peek Tuple6_t, tuple6_var1) ptr- a2' <- (#peek Tuple6_t, tuple6_var2) ptr- a3' <- (#peek Tuple6_t, tuple6_var3) ptr- a4' <- (#peek Tuple6_t, tuple6_var4) ptr- a5' <- (#peek Tuple6_t, tuple6_var5) ptr- a6' <- (#peek Tuple6_t, tuple6_var6) ptr- return $ (Tuple6 a1' a2' a3' a4' a5' a6')---instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => Storable (Tuple7 a b c d e f g) where- sizeOf _ = #size Tuple7_t- alignment _ = #alignment Tuple7_t- - poke ptr (Tuple7 a1 a2 a3 a4 a5 a6 a7) = do- (#poke Tuple7_t, tuple7_var1) ptr a1- (#poke Tuple7_t, tuple7_var2) ptr a2- (#poke Tuple7_t, tuple7_var3) ptr a3- (#poke Tuple7_t, tuple7_var4) ptr a4- (#poke Tuple7_t, tuple7_var5) ptr a5- (#poke Tuple7_t, tuple7_var6) ptr a6- (#poke Tuple7_t, tuple7_var7) ptr a7- peek ptr = do- a1' <- (#peek Tuple7_t, tuple7_var1) ptr- a2' <- (#peek Tuple7_t, tuple7_var2) ptr- a3' <- (#peek Tuple7_t, tuple7_var3) ptr- a4' <- (#peek Tuple7_t, tuple7_var4) ptr- a5' <- (#peek Tuple7_t, tuple7_var5) ptr- a6' <- (#peek Tuple7_t, tuple7_var6) ptr- a7' <- (#peek Tuple7_t, tuple7_var7) ptr- return $ (Tuple7 a1' a2' a3' a4' a5' a6' a7')---instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g, Storable h) => Storable (Tuple8 a b c d e f g h) where- sizeOf _ = #size Tuple8_t- alignment _ = #alignment Tuple8_t- - poke ptr (Tuple8 a1 a2 a3 a4 a5 a6 a7 a8) = do- (#poke Tuple8_t, tuple8_var1) ptr a1- (#poke Tuple8_t, tuple8_var2) ptr a2- (#poke Tuple8_t, tuple8_var3) ptr a3- (#poke Tuple8_t, tuple8_var4) ptr a4- (#poke Tuple8_t, tuple8_var5) ptr a5- (#poke Tuple8_t, tuple8_var6) ptr a6- (#poke Tuple8_t, tuple8_var7) ptr a7- (#poke Tuple8_t, tuple8_var8) ptr a8- peek ptr = do- a1' <- (#peek Tuple8_t, tuple8_var1) ptr- a2' <- (#peek Tuple8_t, tuple8_var2) ptr- a3' <- (#peek Tuple8_t, tuple8_var3) ptr- a4' <- (#peek Tuple8_t, tuple8_var4) ptr- a5' <- (#peek Tuple8_t, tuple8_var5) ptr- a6' <- (#peek Tuple8_t, tuple8_var6) ptr- a7' <- (#peek Tuple8_t, tuple8_var7) ptr- a8' <- (#peek Tuple8_t, tuple8_var8) ptr- return $ (Tuple8 a1' a2' a3' a4' a5' a6' a7' a8')- -instance (Storable a, Storable b) => Storable (a, b) where- sizeOf _ = #size Tuple2_t- alignment _ = #alignment Tuple2_t- - poke ptr (a1, a2) = do- (#poke Tuple2_t, tuple2_var1) ptr a1- (#poke Tuple2_t, tuple2_var2) ptr a2- peek ptr = do- a1' <- (#peek Tuple2_t, tuple2_var1) ptr- a2' <- (#peek Tuple2_t, tuple2_var2) ptr- return $ (a1', a2')- -instance (Storable a, Storable b, Storable c) => Storable (a, b, c) where- sizeOf _ = #size Tuple3_t- alignment _ = #alignment Tuple3_t- - poke ptr (a1, a2, a3) = do- (#poke Tuple3_t, tuple3_var1) ptr a1- (#poke Tuple3_t, tuple3_var2) ptr a2- (#poke Tuple3_t, tuple3_var3) ptr a3- peek ptr = do- a1' <- (#peek Tuple3_t, tuple3_var1) ptr- a2' <- (#peek Tuple3_t, tuple3_var2) ptr- a3' <- (#peek Tuple3_t, tuple3_var3) ptr- return $ (a1', a2', a3')---instance (Storable a, Storable b, Storable c, Storable d) => Storable (a, b, c, d) where- sizeOf _ = #size Tuple4_t- alignment _ = #alignment Tuple4_t- - poke ptr (a1, a2, a3, a4) = do- (#poke Tuple4_t, tuple4_var1) ptr a1- (#poke Tuple4_t, tuple4_var2) ptr a2- (#poke Tuple4_t, tuple4_var3) ptr a3- (#poke Tuple4_t, tuple4_var4) ptr a4- peek ptr = do- a1' <- (#peek Tuple4_t, tuple4_var1) ptr- a2' <- (#peek Tuple4_t, tuple4_var2) ptr- a3' <- (#peek Tuple4_t, tuple4_var3) ptr- a4' <- (#peek Tuple4_t, tuple4_var4) ptr- return $ (a1', a2', a3', a4')---instance (Storable a, Storable b, Storable c, Storable d, Storable e) => Storable (a, b, c, d, e) where- sizeOf _ = #size Tuple5_t- alignment _ = #alignment Tuple5_t- - poke ptr (a1, a2, a3, a4, a5) = do- (#poke Tuple5_t, tuple5_var1) ptr a1- (#poke Tuple5_t, tuple5_var2) ptr a2- (#poke Tuple5_t, tuple5_var3) ptr a3- (#poke Tuple5_t, tuple5_var4) ptr a4- (#poke Tuple5_t, tuple5_var5) ptr a5- peek ptr = do- a1' <- (#peek Tuple5_t, tuple5_var1) ptr- a2' <- (#peek Tuple5_t, tuple5_var2) ptr- a3' <- (#peek Tuple5_t, tuple5_var3) ptr- a4' <- (#peek Tuple5_t, tuple5_var4) ptr- a5' <- (#peek Tuple5_t, tuple5_var5) ptr- return $ (a1', a2', a3', a4', a5')---instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f) => Storable (a, b, c, d, e, f) where- sizeOf _ = #size Tuple6_t- alignment _ = #alignment Tuple6_t- - poke ptr (a1, a2, a3, a4, a5, a6) = do- (#poke Tuple6_t, tuple6_var1) ptr a1- (#poke Tuple6_t, tuple6_var2) ptr a2- (#poke Tuple6_t, tuple6_var3) ptr a3- (#poke Tuple6_t, tuple6_var4) ptr a4- (#poke Tuple6_t, tuple6_var5) ptr a5- (#poke Tuple6_t, tuple6_var6) ptr a6- peek ptr = do- a1' <- (#peek Tuple6_t, tuple6_var1) ptr- a2' <- (#peek Tuple6_t, tuple6_var2) ptr- a3' <- (#peek Tuple6_t, tuple6_var3) ptr- a4' <- (#peek Tuple6_t, tuple6_var4) ptr- a5' <- (#peek Tuple6_t, tuple6_var5) ptr- a6' <- (#peek Tuple6_t, tuple6_var6) ptr- return $ (a1', a2', a3', a4', a5', a6')---instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => Storable (a, b, c, d, e, f, g) where- sizeOf _ = #size Tuple7_t- alignment _ = #alignment Tuple7_t- - poke ptr (a1, a2, a3, a4, a5, a6, a7) = do- (#poke Tuple7_t, tuple7_var1) ptr a1- (#poke Tuple7_t, tuple7_var2) ptr a2- (#poke Tuple7_t, tuple7_var3) ptr a3- (#poke Tuple7_t, tuple7_var4) ptr a4- (#poke Tuple7_t, tuple7_var5) ptr a5- (#poke Tuple7_t, tuple7_var6) ptr a6- (#poke Tuple7_t, tuple7_var7) ptr a7- peek ptr = do- a1' <- (#peek Tuple7_t, tuple7_var1) ptr- a2' <- (#peek Tuple7_t, tuple7_var2) ptr- a3' <- (#peek Tuple7_t, tuple7_var3) ptr- a4' <- (#peek Tuple7_t, tuple7_var4) ptr- a5' <- (#peek Tuple7_t, tuple7_var5) ptr- a6' <- (#peek Tuple7_t, tuple7_var6) ptr- a7' <- (#peek Tuple7_t, tuple7_var7) ptr- return $ (a1', a2', a3', a4', a5', a6', a7')---instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g, Storable h) => Storable (a, b, c, d, e, f, g, h) where- sizeOf _ = #size Tuple8_t- alignment _ = #alignment Tuple8_t- - poke ptr (a1, a2, a3, a4, a5, a6, a7, a8) = do- (#poke Tuple8_t, tuple8_var1) ptr a1- (#poke Tuple8_t, tuple8_var2) ptr a2- (#poke Tuple8_t, tuple8_var3) ptr a3- (#poke Tuple8_t, tuple8_var4) ptr a4- (#poke Tuple8_t, tuple8_var5) ptr a5- (#poke Tuple8_t, tuple8_var6) ptr a6- (#poke Tuple8_t, tuple8_var7) ptr a7- (#poke Tuple8_t, tuple8_var8) ptr a8- peek ptr = do- a1' <- (#peek Tuple8_t, tuple8_var1) ptr- a2' <- (#peek Tuple8_t, tuple8_var2) ptr- a3' <- (#peek Tuple8_t, tuple8_var3) ptr- a4' <- (#peek Tuple8_t, tuple8_var4) ptr- a5' <- (#peek Tuple8_t, tuple8_var5) ptr- a6' <- (#peek Tuple8_t, tuple8_var6) ptr- a7' <- (#peek Tuple8_t, tuple8_var7) ptr- a8' <- (#peek Tuple8_t, tuple8_var8) ptr- return $ (a1', a2', a3', a4', a5', a6', a7', a8')
+ WinDll/Lib/Tuples.xpphs view
@@ -0,0 +1,3 @@+#undef DEBUG++#include "Tuples_Base.cpphs"
+ WinDll/Lib/Tuples_Base.cpphs view
@@ -0,0 +1,508 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ForeignFunctionInterface #-}++-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Module containing definitions for tuples, since those can't be automatically+-- translated. We This file contains predefined mappings of tuples till 8-tuples.+-- If you need more you need to unfortunately add these yourself+--+-----------------------------------------------------------------------------++#ifdef DEBUG+module WinDll.Lib.Tuples_Debug where+#else+module WinDll.Lib.Tuples where+#endif++#if defined(DEBUG)+import Foreign hiding (free, malloc, alloca, realloc)+import Foreign.Marshal.Alloc hiding (free, malloc, alloca, realloc)+import WinDll.Lib.NativeMapping_Debug+#else+import Foreign+import Foreign.Marshal.Alloc+import WinDll.Lib.NativeMapping+#endif++import Foreign+import Foreign.C+import Foreign.Ptr+import qualified Foreign.Marshal.Alloc as F+import Foreign.Marshal.Utils++import Control.Monad+import Control.Monad.Instances++#ifdef DEBUG+import WinDll.Debug.Stack+import WinDll.Debug.Alloc+#endif++#define _INCLUDE_ #include "Tuples.h"+#define _LET_ #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)++#if defined(DEBUG)+#define _CONST_ const+#define _ID_ const id+#define _ST_ st+#define RECORD(file,line,name,fn) \st ptr -> record (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) ptr >> return (fn ptr)+#define RECORDM(file,line,name,fn) \st val -> recordM (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) val fn+#define FREE(file,line,name,fn) \st _ ptr -> freeDefault (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) ptr fn+#define UFREE(file,line,name,fn) \st _ ptr -> freeUnknown (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) ptr fn+#else+#define _CONST_+#define _ST_ +#define _ID_ id+#define RECORD(file,line,name,fn) \ptr -> return (fn ptr)+#define RECORDM(file,line,name,fn) fn+#define FREE(file,line,name,fn) \_ -> fn+#define UFREE(file,line,name,fn) \_ -> fn+#endif++_LET_+_INCLUDE_++-- * The datatypes to replace the tupples with++data Tuple2 a b = Tuple2 a b+data Tuple3 a b c = Tuple3 a b c+data Tuple4 a b c d = Tuple4 a b c d+data Tuple5 a b c d e = Tuple5 a b c d e+data Tuple6 a b c d e f = Tuple6 a b c d e f+data Tuple7 a b c d e f g = Tuple7 a b c d e f g+data Tuple8 a b c d e f g h = Tuple8 a b c d e f g h++-- * Type namings++type Tuple2Ptr a b = Ptr (Tuple2 a b)+type Tuple3Ptr a b c = Ptr (Tuple3 a b c)+type Tuple4Ptr a b c d = Ptr (Tuple4 a b c d)+type Tuple5Ptr a b c d e = Ptr (Tuple5 a b c d e)+type Tuple6Ptr a b c d e f = Ptr (Tuple6 a b c d e f)+type Tuple7Ptr a b c d e f g = Ptr (Tuple7 a b c d e f g)+type Tuple8Ptr a b c d e f g h = Ptr (Tuple8 a b c d e f g h)++-- * Functor instances so that these new tuple types can+-- fit into the functor instance of the FFIType class.+instance Storable a => Functor (Tuple2 a) where+ fmap f (Tuple2 a b) = Tuple2 a (f b)+ +instance Storable a => Functor (Tuple3 a b) where+ fmap f (Tuple3 a b c) = Tuple3 a b (f c)+ +instance Storable a => Functor (Tuple4 a b c) where+ fmap f (Tuple4 a b c d) = Tuple4 a b c (f d)+ +instance Storable a => Functor (Tuple5 a b c d) where+ fmap f (Tuple5 a b c d e) = Tuple5 a b c d (f e)+ +instance Storable a => Functor (Tuple6 a b c d e) where+ fmap f (Tuple6 a b c d e f') = Tuple6 a b c d e (f f')+ +instance Storable a => Functor (Tuple7 a b c d e f) where+ fmap f (Tuple7 a b c d e f' g) = Tuple7 a b c d e f' (f g)+ +instance Storable a => Functor (Tuple8 a b c d e f g) where+ fmap f (Tuple8 a b c d e f' g h) = Tuple8 a b c d e f' g (f h)++-- * The isomorphic type conversions++instance (FFIType a b,FFIType c d) => FFIType (a,c) + (Tuple2 b d) where+ toFFI _ST_ (a,b) = (Tuple2 (toFFI _ST_ a) (toFFI _ST_ b))+ fromFFI _ST_ (Tuple2 a b) = (fromFFI _ST_ a, fromFFI _ST_ b)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f) => FFIType (a,c,e) + (Tuple3 b d f) where+ toFFI _ST_ (a,b,c) = (Tuple3 (toFFI _ST_ a) (toFFI _ST_ b) (toFFI _ST_ c))+ fromFFI _ST_ (Tuple3 a b c) = (fromFFI _ST_ a, fromFFI _ST_ b, fromFFI _ST_ c)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f,FFIType g h) => FFIType (a,c,e,g) + (Tuple4 b d f h) where+ toFFI _ST_ (a,b,c,d) = (Tuple4 (toFFI _ST_ a) (toFFI _ST_ b) (toFFI _ST_ c) (toFFI _ST_ d))+ fromFFI _ST_ (Tuple4 a b c d) = (fromFFI _ST_ a, fromFFI _ST_ b, fromFFI _ST_ c, fromFFI _ST_ d)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f,FFIType g h+ ,FFIType i j) => FFIType (a,c,e,g,i) + (Tuple5 b d f h j) where+ toFFI _ST_ (a,b,c,d,e) = (Tuple5 (toFFI _ST_ a) (toFFI _ST_ b) (toFFI _ST_ c) (toFFI _ST_ d) + (toFFI _ST_ e))+ fromFFI _ST_ (Tuple5 a b c d e) = (fromFFI _ST_ a, fromFFI _ST_ b, fromFFI _ST_ c, fromFFI _ST_ d+ ,fromFFI _ST_ e)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f,FFIType g h+ ,FFIType i j,FFIType k l) => FFIType (a,c,e,g,i,k) (Tuple6 b d f h j l) where+ toFFI _ST_ (a,b,c,d,e,f) = (Tuple6 (toFFI _ST_ a) (toFFI _ST_ b) (toFFI _ST_ c) (toFFI _ST_ d) + (toFFI _ST_ e) (toFFI _ST_ f))+ fromFFI _ST_ (Tuple6 a b c d e f) = (fromFFI _ST_ a, fromFFI _ST_ b, fromFFI _ST_ c, fromFFI _ST_ d+ ,fromFFI _ST_ e, fromFFI _ST_ f)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f,FFIType g h+ ,FFIType i j,FFIType k l+ ,FFIType m n) => FFIType (a,c,e,g,i,k,m) + (Tuple7 b d f h j l n) where+ toFFI _ST_ (a,b,c,d,e,f,g) = (Tuple7 (toFFI _ST_ a) (toFFI _ST_ b) (toFFI _ST_ c) (toFFI _ST_ d) + (toFFI _ST_ e) (toFFI _ST_ f) (toFFI _ST_ g))+ fromFFI _ST_ (Tuple7 a b c d e f g) = (fromFFI _ST_ a, fromFFI _ST_ b, fromFFI _ST_ c, fromFFI _ST_ d+ ,fromFFI _ST_ e, fromFFI _ST_ f, fromFFI _ST_ g)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f,FFIType g h+ ,FFIType i j,FFIType k l+ ,FFIType m n,FFIType o p) => FFIType (a,c,e,g,i,k,m,o) + (Tuple8 b d f h j l n p) where+ toFFI _ST_ (a,b,c,d,e,f,g,h) = (Tuple8 (toFFI _ST_ a) (toFFI _ST_ b) (toFFI _ST_ c) (toFFI _ST_ d) + (toFFI _ST_ e) (toFFI _ST_ f) (toFFI _ST_ g) (toFFI _ST_ h))+ fromFFI _ST_ (Tuple8 a b c d e f g h) = (fromFFI _ST_ a, fromFFI _ST_ b, fromFFI _ST_ c, fromFFI _ST_ d+ ,fromFFI _ST_ e, fromFFI _ST_ f, fromFFI _ST_ g, fromFFI _ST_ h)+++instance (FFIType a b,FFIType c d+ ,Storable b, Storable d) => FFIType (a,c) + (Tuple2Ptr b d) where+ toNative = RECORDM(__FILE__, __LINE__, "newTuple2" , (new . (toFFI _ST_)))+ fromNative = RECORD(__FILE__, __LINE__, "fromTuple2" , id) >>= fmap (fromFFI _ST_) . peek+ freeFFI = FREE( __FILE__, __LINE__, "freeTuple2", F.free)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f,Storable b+ ,Storable d, Storable f) => FFIType (a,c,e) + (Tuple3Ptr b d f) where+ toNative = RECORDM(__FILE__, __LINE__, "newTuple3" , (new . (toFFI _ST_)))+ fromNative = RECORD(__FILE__, __LINE__, "fromTuple3" , id) >>= fmap (fromFFI _ST_) . peek+ freeFFI = FREE( __FILE__, __LINE__, "freeTuple3", F.free)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f,FFIType g h+ ,Storable b,Storable d+ ,Storable f,Storable h) => FFIType (a,c,e,g) + (Tuple4Ptr b d f h) where+ toNative = RECORDM(__FILE__, __LINE__, "newTuple4" , (new . (toFFI _ST_)))+ fromNative = RECORD(__FILE__, __LINE__, "fromTuple4" , id) >>= fmap (fromFFI _ST_) . peek+ freeFFI = FREE( __FILE__, __LINE__, "freeTuple4", F.free)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f,FFIType g h+ ,FFIType i j,Storable j+ ,Storable b,Storable d+ ,Storable f,Storable h) => FFIType (a,c,e,g,i) + (Tuple5Ptr b d f h j) where+ toNative = RECORDM(__FILE__, __LINE__, "newTuple5" , (new . (toFFI _ST_)))+ fromNative = RECORD(__FILE__, __LINE__, "fromTuple5" , id) >>= fmap (fromFFI _ST_) . peek+ freeFFI = FREE( __FILE__, __LINE__, "freeTuple5", F.free)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f,FFIType g h+ ,FFIType i j,FFIType k l+ ,Storable j,Storable l+ ,Storable b,Storable d+ ,Storable f,Storable h) => FFIType (a,c,e,g,i,k) + (Tuple6Ptr b d f h j l) where+ toNative = RECORDM(__FILE__, __LINE__, "newTuple6" , (new . (toFFI _ST_)))+ fromNative = RECORD(__FILE__, __LINE__, "fromTuple6" , id) >>= fmap (fromFFI _ST_) . peek+ freeFFI = FREE( __FILE__, __LINE__, "freeTuple6", F.free)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f,FFIType g h+ ,FFIType i j,FFIType k l+ ,FFIType m n,Storable n+ ,Storable j,Storable l+ ,Storable b,Storable d+ ,Storable f,Storable h) => FFIType (a,c,e,g,i,k,m) + (Tuple7Ptr b d f h j l n) where+ toNative = RECORDM(__FILE__, __LINE__, "newTuple7" , (new . (toFFI _ST_)))+ fromNative = RECORD(__FILE__, __LINE__, "fromTuple7" , id) >>= fmap (fromFFI _ST_) . peek+ freeFFI = FREE( __FILE__, __LINE__, "freeTuple7", F.free)+ +instance (FFIType a b,FFIType c d+ ,FFIType e f,FFIType g h+ ,FFIType i j,FFIType k l+ ,FFIType m n,FFIType o p+ ,Storable n,Storable p+ ,Storable j,Storable l+ ,Storable b,Storable d+ ,Storable f,Storable h) => FFIType (a,c,e,g,i,k,m,o) + (Tuple8Ptr b d f h j l n p) where+ toNative = RECORDM(__FILE__, __LINE__, "newTuple8" , (new . (toFFI _ST_)))+ fromNative = RECORD(__FILE__, __LINE__, "fromTuple8" , id) >>= fmap (fromFFI _ST_) . peek+ freeFFI = FREE( __FILE__, __LINE__, "freeTuple8", F.free)+ +-- * Storage instances++instance (Storable a, Storable b) => Storable (Tuple2 a b) where+ sizeOf _ = #size Tuple2_t+ alignment _ = #alignment Tuple2_t+ + poke ptr (Tuple2 a1 a2) = do+ (#poke Tuple2_t, tuple2_var1) ptr a1+ (#poke Tuple2_t, tuple2_var2) ptr a2+ peek ptr = do+ a1' <- (#peek Tuple2_t, tuple2_var1) ptr+ a2' <- (#peek Tuple2_t, tuple2_var2) ptr+ return $ (Tuple2 a1' a2')+ +instance (Storable a, Storable b, Storable c) => Storable (Tuple3 a b c) where+ sizeOf _ = #size Tuple3_t+ alignment _ = #alignment Tuple3_t+ + poke ptr (Tuple3 a1 a2 a3) = do+ (#poke Tuple3_t, tuple3_var1) ptr a1+ (#poke Tuple3_t, tuple3_var2) ptr a2+ (#poke Tuple3_t, tuple3_var3) ptr a3+ peek ptr = do+ a1' <- (#peek Tuple3_t, tuple3_var1) ptr+ a2' <- (#peek Tuple3_t, tuple3_var2) ptr+ a3' <- (#peek Tuple3_t, tuple3_var3) ptr+ return $ (Tuple3 a1' a2' a3')+++instance (Storable a, Storable b, Storable c, Storable d) => Storable (Tuple4 a b c d) where+ sizeOf _ = #size Tuple4_t+ alignment _ = #alignment Tuple4_t+ + poke ptr (Tuple4 a1 a2 a3 a4) = do+ (#poke Tuple4_t, tuple4_var1) ptr a1+ (#poke Tuple4_t, tuple4_var2) ptr a2+ (#poke Tuple4_t, tuple4_var3) ptr a3+ (#poke Tuple4_t, tuple4_var4) ptr a4+ peek ptr = do+ a1' <- (#peek Tuple4_t, tuple4_var1) ptr+ a2' <- (#peek Tuple4_t, tuple4_var2) ptr+ a3' <- (#peek Tuple4_t, tuple4_var3) ptr+ a4' <- (#peek Tuple4_t, tuple4_var4) ptr+ return $ (Tuple4 a1' a2' a3' a4')+++instance (Storable a, Storable b, Storable c, Storable d, Storable e) => Storable (Tuple5 a b c d e) where+ sizeOf _ = #size Tuple5_t+ alignment _ = #alignment Tuple5_t+ + poke ptr (Tuple5 a1 a2 a3 a4 a5) = do+ (#poke Tuple5_t, tuple5_var1) ptr a1+ (#poke Tuple5_t, tuple5_var2) ptr a2+ (#poke Tuple5_t, tuple5_var3) ptr a3+ (#poke Tuple5_t, tuple5_var4) ptr a4+ (#poke Tuple5_t, tuple5_var5) ptr a5+ peek ptr = do+ a1' <- (#peek Tuple5_t, tuple5_var1) ptr+ a2' <- (#peek Tuple5_t, tuple5_var2) ptr+ a3' <- (#peek Tuple5_t, tuple5_var3) ptr+ a4' <- (#peek Tuple5_t, tuple5_var4) ptr+ a5' <- (#peek Tuple5_t, tuple5_var5) ptr+ return $ (Tuple5 a1' a2' a3' a4' a5')+++instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f) => Storable (Tuple6 a b c d e f) where+ sizeOf _ = #size Tuple6_t+ alignment _ = #alignment Tuple6_t+ + poke ptr (Tuple6 a1 a2 a3 a4 a5 a6) = do+ (#poke Tuple6_t, tuple6_var1) ptr a1+ (#poke Tuple6_t, tuple6_var2) ptr a2+ (#poke Tuple6_t, tuple6_var3) ptr a3+ (#poke Tuple6_t, tuple6_var4) ptr a4+ (#poke Tuple6_t, tuple6_var5) ptr a5+ (#poke Tuple6_t, tuple6_var6) ptr a6+ peek ptr = do+ a1' <- (#peek Tuple6_t, tuple6_var1) ptr+ a2' <- (#peek Tuple6_t, tuple6_var2) ptr+ a3' <- (#peek Tuple6_t, tuple6_var3) ptr+ a4' <- (#peek Tuple6_t, tuple6_var4) ptr+ a5' <- (#peek Tuple6_t, tuple6_var5) ptr+ a6' <- (#peek Tuple6_t, tuple6_var6) ptr+ return $ (Tuple6 a1' a2' a3' a4' a5' a6')+++instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => Storable (Tuple7 a b c d e f g) where+ sizeOf _ = #size Tuple7_t+ alignment _ = #alignment Tuple7_t+ + poke ptr (Tuple7 a1 a2 a3 a4 a5 a6 a7) = do+ (#poke Tuple7_t, tuple7_var1) ptr a1+ (#poke Tuple7_t, tuple7_var2) ptr a2+ (#poke Tuple7_t, tuple7_var3) ptr a3+ (#poke Tuple7_t, tuple7_var4) ptr a4+ (#poke Tuple7_t, tuple7_var5) ptr a5+ (#poke Tuple7_t, tuple7_var6) ptr a6+ (#poke Tuple7_t, tuple7_var7) ptr a7+ peek ptr = do+ a1' <- (#peek Tuple7_t, tuple7_var1) ptr+ a2' <- (#peek Tuple7_t, tuple7_var2) ptr+ a3' <- (#peek Tuple7_t, tuple7_var3) ptr+ a4' <- (#peek Tuple7_t, tuple7_var4) ptr+ a5' <- (#peek Tuple7_t, tuple7_var5) ptr+ a6' <- (#peek Tuple7_t, tuple7_var6) ptr+ a7' <- (#peek Tuple7_t, tuple7_var7) ptr+ return $ (Tuple7 a1' a2' a3' a4' a5' a6' a7')+++instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g, Storable h) => Storable (Tuple8 a b c d e f g h) where+ sizeOf _ = #size Tuple8_t+ alignment _ = #alignment Tuple8_t+ + poke ptr (Tuple8 a1 a2 a3 a4 a5 a6 a7 a8) = do+ (#poke Tuple8_t, tuple8_var1) ptr a1+ (#poke Tuple8_t, tuple8_var2) ptr a2+ (#poke Tuple8_t, tuple8_var3) ptr a3+ (#poke Tuple8_t, tuple8_var4) ptr a4+ (#poke Tuple8_t, tuple8_var5) ptr a5+ (#poke Tuple8_t, tuple8_var6) ptr a6+ (#poke Tuple8_t, tuple8_var7) ptr a7+ (#poke Tuple8_t, tuple8_var8) ptr a8+ peek ptr = do+ a1' <- (#peek Tuple8_t, tuple8_var1) ptr+ a2' <- (#peek Tuple8_t, tuple8_var2) ptr+ a3' <- (#peek Tuple8_t, tuple8_var3) ptr+ a4' <- (#peek Tuple8_t, tuple8_var4) ptr+ a5' <- (#peek Tuple8_t, tuple8_var5) ptr+ a6' <- (#peek Tuple8_t, tuple8_var6) ptr+ a7' <- (#peek Tuple8_t, tuple8_var7) ptr+ a8' <- (#peek Tuple8_t, tuple8_var8) ptr+ return $ (Tuple8 a1' a2' a3' a4' a5' a6' a7' a8')+ +instance (Storable a, Storable b) => Storable (a, b) where+ sizeOf _ = #size Tuple2_t+ alignment _ = #alignment Tuple2_t+ + poke ptr (a1, a2) = do+ (#poke Tuple2_t, tuple2_var1) ptr a1+ (#poke Tuple2_t, tuple2_var2) ptr a2+ peek ptr = do+ a1' <- (#peek Tuple2_t, tuple2_var1) ptr+ a2' <- (#peek Tuple2_t, tuple2_var2) ptr+ return $ (a1', a2')+ +instance (Storable a, Storable b, Storable c) => Storable (a, b, c) where+ sizeOf _ = #size Tuple3_t+ alignment _ = #alignment Tuple3_t+ + poke ptr (a1, a2, a3) = do+ (#poke Tuple3_t, tuple3_var1) ptr a1+ (#poke Tuple3_t, tuple3_var2) ptr a2+ (#poke Tuple3_t, tuple3_var3) ptr a3+ peek ptr = do+ a1' <- (#peek Tuple3_t, tuple3_var1) ptr+ a2' <- (#peek Tuple3_t, tuple3_var2) ptr+ a3' <- (#peek Tuple3_t, tuple3_var3) ptr+ return $ (a1', a2', a3')+++instance (Storable a, Storable b, Storable c, Storable d) => Storable (a, b, c, d) where+ sizeOf _ = #size Tuple4_t+ alignment _ = #alignment Tuple4_t+ + poke ptr (a1, a2, a3, a4) = do+ (#poke Tuple4_t, tuple4_var1) ptr a1+ (#poke Tuple4_t, tuple4_var2) ptr a2+ (#poke Tuple4_t, tuple4_var3) ptr a3+ (#poke Tuple4_t, tuple4_var4) ptr a4+ peek ptr = do+ a1' <- (#peek Tuple4_t, tuple4_var1) ptr+ a2' <- (#peek Tuple4_t, tuple4_var2) ptr+ a3' <- (#peek Tuple4_t, tuple4_var3) ptr+ a4' <- (#peek Tuple4_t, tuple4_var4) ptr+ return $ (a1', a2', a3', a4')+++instance (Storable a, Storable b, Storable c, Storable d, Storable e) => Storable (a, b, c, d, e) where+ sizeOf _ = #size Tuple5_t+ alignment _ = #alignment Tuple5_t+ + poke ptr (a1, a2, a3, a4, a5) = do+ (#poke Tuple5_t, tuple5_var1) ptr a1+ (#poke Tuple5_t, tuple5_var2) ptr a2+ (#poke Tuple5_t, tuple5_var3) ptr a3+ (#poke Tuple5_t, tuple5_var4) ptr a4+ (#poke Tuple5_t, tuple5_var5) ptr a5+ peek ptr = do+ a1' <- (#peek Tuple5_t, tuple5_var1) ptr+ a2' <- (#peek Tuple5_t, tuple5_var2) ptr+ a3' <- (#peek Tuple5_t, tuple5_var3) ptr+ a4' <- (#peek Tuple5_t, tuple5_var4) ptr+ a5' <- (#peek Tuple5_t, tuple5_var5) ptr+ return $ (a1', a2', a3', a4', a5')+++instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f) => Storable (a, b, c, d, e, f) where+ sizeOf _ = #size Tuple6_t+ alignment _ = #alignment Tuple6_t+ + poke ptr (a1, a2, a3, a4, a5, a6) = do+ (#poke Tuple6_t, tuple6_var1) ptr a1+ (#poke Tuple6_t, tuple6_var2) ptr a2+ (#poke Tuple6_t, tuple6_var3) ptr a3+ (#poke Tuple6_t, tuple6_var4) ptr a4+ (#poke Tuple6_t, tuple6_var5) ptr a5+ (#poke Tuple6_t, tuple6_var6) ptr a6+ peek ptr = do+ a1' <- (#peek Tuple6_t, tuple6_var1) ptr+ a2' <- (#peek Tuple6_t, tuple6_var2) ptr+ a3' <- (#peek Tuple6_t, tuple6_var3) ptr+ a4' <- (#peek Tuple6_t, tuple6_var4) ptr+ a5' <- (#peek Tuple6_t, tuple6_var5) ptr+ a6' <- (#peek Tuple6_t, tuple6_var6) ptr+ return $ (a1', a2', a3', a4', a5', a6')+++instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => Storable (a, b, c, d, e, f, g) where+ sizeOf _ = #size Tuple7_t+ alignment _ = #alignment Tuple7_t+ + poke ptr (a1, a2, a3, a4, a5, a6, a7) = do+ (#poke Tuple7_t, tuple7_var1) ptr a1+ (#poke Tuple7_t, tuple7_var2) ptr a2+ (#poke Tuple7_t, tuple7_var3) ptr a3+ (#poke Tuple7_t, tuple7_var4) ptr a4+ (#poke Tuple7_t, tuple7_var5) ptr a5+ (#poke Tuple7_t, tuple7_var6) ptr a6+ (#poke Tuple7_t, tuple7_var7) ptr a7+ peek ptr = do+ a1' <- (#peek Tuple7_t, tuple7_var1) ptr+ a2' <- (#peek Tuple7_t, tuple7_var2) ptr+ a3' <- (#peek Tuple7_t, tuple7_var3) ptr+ a4' <- (#peek Tuple7_t, tuple7_var4) ptr+ a5' <- (#peek Tuple7_t, tuple7_var5) ptr+ a6' <- (#peek Tuple7_t, tuple7_var6) ptr+ a7' <- (#peek Tuple7_t, tuple7_var7) ptr+ return $ (a1', a2', a3', a4', a5', a6', a7')+++instance (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g, Storable h) => Storable (a, b, c, d, e, f, g, h) where+ sizeOf _ = #size Tuple8_t+ alignment _ = #alignment Tuple8_t+ + poke ptr (a1, a2, a3, a4, a5, a6, a7, a8) = do+ (#poke Tuple8_t, tuple8_var1) ptr a1+ (#poke Tuple8_t, tuple8_var2) ptr a2+ (#poke Tuple8_t, tuple8_var3) ptr a3+ (#poke Tuple8_t, tuple8_var4) ptr a4+ (#poke Tuple8_t, tuple8_var5) ptr a5+ (#poke Tuple8_t, tuple8_var6) ptr a6+ (#poke Tuple8_t, tuple8_var7) ptr a7+ (#poke Tuple8_t, tuple8_var8) ptr a8+ peek ptr = do+ a1' <- (#peek Tuple8_t, tuple8_var1) ptr+ a2' <- (#peek Tuple8_t, tuple8_var2) ptr+ a3' <- (#peek Tuple8_t, tuple8_var3) ptr+ a4' <- (#peek Tuple8_t, tuple8_var4) ptr+ a5' <- (#peek Tuple8_t, tuple8_var5) ptr+ a6' <- (#peek Tuple8_t, tuple8_var6) ptr+ a7' <- (#peek Tuple8_t, tuple8_var7) ptr+ a8' <- (#peek Tuple8_t, tuple8_var8) ptr+ return $ (a1', a2', a3', a4', a5', a6', a7', a8')
+ WinDll/Lib/Tuples_Debug.xpphs view
@@ -0,0 +1,3 @@+#define DEBUG 1++#include "Tuples_Base.cpphs"
− WinDll/Parsers.hs
@@ -1,566 +0,0 @@- {-# LANGUAGE RelaxedPolyRec #-}---------------------------------------------------------------------------------- |--- Module : Windll--- Copyright : (c) Tamar Christina 2009 - 2010--- License : BSD3--- --- Maintainer : tamar@zhox.com--- Stability : experimental--- Portability : portable------ Parsers for the preprocessor. Parses using Haskell-src-exts --- to the simple datatype in \WinDll.Structs.Structures\-----------------------------------------------------------------------------------module WinDll.Parsers where--import Language.Haskell.Exts-import Language.Haskell.Exts.Extension-import qualified Language.Haskell.Exts as Exts-import Language.Haskell.Exts.Parser-import Language.Haskell.Exts.Syntax-import Language.Haskell.Exts.SrcLoc-import Language.Haskell.Exts.Comments--import Data.Generics--import Data.IORef--import Data.List-import Data.Char-import Data.Maybe--import System.IO.Unsafe-import System.FilePath-import System.Directory--import Control.Monad--import WinDll.Structs.Structures hiding (Module)-import qualified WinDll.Structs.Structures as WinDll-import WinDll.Session-import WinDll.Version-import WinDll.Utils.Feedback-import WinDll.Structs.PrettyPrinting-import WinDll.Structs.MShow.HaskellSrcExts-import WinDll.Structs.MShow.MShow-import WinDll.Structs.Folds.HaskellSrcExts-import WinDll.Utils.Types--import qualified Debug.Trace as D---- testFile = "C:\\Users\\Phyx\\Documents\\Haskell\\WinDLL\\test.hs"-testFile = "C:\\Users\\Phyx\\Documents\\Desktop\\native\\GHCDll.hs"--instance Num SrcLoc where- (SrcLoc f l1 c1) - (SrcLoc _ l2 c2) = SrcLoc f (l1-l2) (c1-c2)- (SrcLoc f l1 c1) + (SrcLoc _ l2 c2) = SrcLoc f (l1+l2) (c1+c2)- (SrcLoc f l1 c1) * (SrcLoc _ l2 c2) = SrcLoc f (l1*l2) (c1*c2)- abs (SrcLoc f l c) = SrcLoc f (abs l) (abs c)- signum (SrcLoc f l c) = SrcLoc f (signum l) (signum c)- fromInteger i = SrcLoc [] (fromInteger i) 0- --- instance Ord Decl where- -- compare a b = if (a == b) then EQ else LT---- | Read a file in, And store it in the list of \WinDll.Module\ and \WinDll.CodeGen.CommentDecl\-readFromFiles :: Exec ()-readFromFiles = - do session <- get- inform _normal "Reading and parsing all dependencies..."- let workset = workingset session- (result, c0) <- liftM unzip $ forM (absPath session : map guessPath ((drop 1 (dependencies workset))++includes session)) pdata- put $ session { workingset = workset { modules = result- , pragmas = catMaybes (parseComments (join c0)) } }- where pdata :: FilePath -> Exec ((WinDll.Module, [CommentDecl]),[Comment])- pdata path = - do (m0,c0) <- parseFromFile path- inform _detail "Converting AST to internal representation..."- moddata' <- convertModule m0 c0- inform _detail "Updating module name..."- let moddata = moddata' { header = (header moddata') { headername = reverse $ drop 1 $ dropWhile (/='.') $ reverse $ takeFileName path } }- inform _detail "Matching and resolving comments..."- let modcomment = matchFunctionsWithComments c0 (findTypeSignatures m0)- inform _detail ("Finished processing " ++ path ++ "...\n")- return ((moddata,modcomment), c0)- - fixDependencies :: String -> FilePath- fixDependencies current = let ldata = map (\a-> if a == '.' then pathSeparator else a) current- fdata = ldata++".hs"- in case unsafePerformIO (doesFileExist fdata) of- True -> fdata- False -> ldata ++ ".lhs"- --- | Convert the right comments to the correct pragmas. These are all globally scoped.--- .--- . supported pragmas are:--- . {- @@ HS2LIB_OPTS <opts> @@ -} -=- turn on dynamic options present in this file--- . {- @@ INSTANCE <name> <count> @@ -} -=- generate type info required to work correctly but also hides the warning of missing data definition--- . {- @@ IMPORT <list> @@ -} -=- Imports to carry over to the new generated module--- . {- @@ HS2C <htype> <type>@<size> @@ -} -=- Specifies what to translate the Haskell htype to the C type, but we also need its size in bytes--- . {- @@ HS2C# <htype> <c#type> @@ -} -=- Specifies what to translate the Haskell htype to the C# type, but we also need its size in bytes--- . {- @@ HS2HS <htype> <htype> @@ -} -=- Specifies what to translate the Haskell htype should be in terms of a compatible FFI type. --- . There needs to be an FFIType instance for these types, or be covered by one of the defaults`--- . -parseComments :: [Comment] -> [Maybe Pragma]-parseComments [] = []-parseComments ((Comment True _ s):xs) = f (trim s): parseComments xs- where f :: String -> Maybe Pragma- f s | "@@ " `isPrefixOf` s && " @@" `isSuffixOf` s = let stack = trim (drop 3 (take (length s - 3) s))- (x:xs) = lexwords stack- name = (map toUpper x)- xs' = if name == (upper_name ++"_OPTS") then tail $ words stack else xs- in if null stack then Nothing else Just (Pragma name xs')- | otherwise = Nothing- - trim :: String -> String- trim = reverse . dropWhile (==' ') . reverse . dropWhile (==' ')-parseComments (_ :xs) = parseComments xs--lexwords :: String -> [String]-lexwords [] = []-lexwords str = let res = lex str- (cur,rest) = head res- cur' = case cur of- [] -> []- '"':xs -> init xs : lexwords rest- '-':_ -> let other = lexwords rest- (x:xs) = other- in if null other then cur : other else (cur++x) : xs- x -> x : lexwords rest- in if null res then [] else cur'- --- | Parse a module from file while retaining comments-parseFromFile :: FilePath -> Exec (Module, [Comment])-parseFromFile path = - do inform _detail ("Parsing '" ++ path ++ "'")- result <- liftIO $ parseFileWithComments (defaultParseMode { extensions = (TemplateHaskell:BangPatterns:NamedFieldPuns:ExplicitForall:glasgowExts), parseFilename = path }) path- case result of- (ParseOk a) -> return a- (ParseFailed loc str) -> die (exename ++ " parse failure, reason: " ++ str ++ " at " ++ show loc)---- | Finds all the type declarations from a given file.-findTypeSignatures :: Module -> [Decl]-findTypeSignatures = listify inner- where inner (TypeSig _ _ _) = True- inner _ = False---- | Finds all the type synonym declarations from a given file.-findTypeDecl :: Module -> [Decl]-findTypeDecl = listify inner- where inner (TypeDecl _ _ _ _) = True- inner _ = False---- | Finds all the foreign export declarations in a file-findForeignExports :: Module -> [Decl]-findForeignExports = listify inner- where inner (ForExp _ _ _ _ _) = True- inner _ = False- --- | Finds all the newtype or data declarations withing the given structure-findDataDeclarations :: Module -> [Decl]-findDataDeclarations = listify inner- where inner (DataDecl _ _ _ _ _ _ _) = True- inner _ = False- --- | Finds all the Storable instances declarations-findStorableDeclarations :: Module -> [Decl]-findStorableDeclarations = listify inner- where inner (InstDecl _ _ name _ _ ) = "Storable" `elem` (findStrings name)- inner _ = False- --- | Match function and comments to eachother and determine which comments indicate out special -- \@\@ comment flag-matchFunctionsWithComments :: [Comment] -> [Decl] -> [CommentDecl]-matchFunctionsWithComments comments decls = - let directives = filter (\t->"@@" `isPrefixOf` strip (readComment t)) comments- in merge $ catMaybes $ map (matchDecl decls) (map convertComment directives)- where readComment :: Comment -> String- readComment (Comment _ _ s) = s- - convertComment :: Comment -> MyComment- convertComment (Comment _ l s) = MyComment l s- - strip :: String -> String- strip = dropWhile isSpace- - maxScore :: Int- maxScore = 500-- getScore :: SrcLoc -> Int- getScore (SrcLoc _ l f) = if l > 0 then l else maxScore -- l*l + f*f- - convertLoc :: SrcSpan -> SrcLoc- convertLoc (SrcSpan n l f _ _) = SrcLoc n l f- - matchDecl :: [Decl] -> MyComment -> Maybe CommentDecl- matchDecl decls (MyComment l s) = - let ordered = sort $ map (\t@(TypeSig d _ _)->(getScore (d- (convertLoc l)),([s],t))) decls- value = head ordered- score = fst value- in if score < maxScore then Just (snd value) else Nothing- - merge :: [CommentDecl] -> [CommentDecl]- merge [] = []- merge x = map (foldr1 (\(a,_) (b,f)->(a++b,f))) $ groupBy (\a b->snd a==snd b) x- --- | Standard imports list for all generated moduels-stdImports :: [Import]-stdImports = ["WinDll.Lib.NativeMapping"- ,"WinDll.Lib.Tuples"- ,"WinDll.Lib.InstancesTypes"- ,"Foreign"- ,"Foreign.C"- ,"Foreign.C.Types"- ,"Foreign.Ptr"- ,"Foreign.Marshal.Alloc"- ,"Foreign.Marshal.Utils"- ,"Foreign.ForeignPtr"- ]- --- | Convert the parsed Haskell-src-exts to the internal Module definition.--- A nother limitation to get this done on time, is that i don't support infix constructors-convertModule :: Module -> [Comment] -> Exec WinDll.Module-convertModule m@(Module (SrcLoc file _ _) (ModuleName name) _ _ _ _ decl) comments = - let header = Header name []- exports = map createExport t_func- datatypes = map createDataType t_data- functions = map createFunction t_func- tdecl = map createTypeSyn t_type- instances = map createInstance t_inst- foreigns = map createForeign t_fexpr- - t_func = filter isExport $ fixC $ matchFunctionsWithComments comments (findTypeSignatures m)- t_data = findDataDeclarations m- t_type = findTypeDecl m- t_inst = findStorableDeclarations m- t_fexpr = findForeignExports m- - in do session <- get- let workset = workingset session- newset = workset { n_exports = n_exports workset ++ foreigns }- newsess = session { workingset = newset }- put newsess- return $ WinDll.Module header file (name:stdImports) exports datatypes functions instances tdecl- where isExport :: CommentDecl -> Bool- isExport (flags, _) = any (isPrefixOf "export") (map (map toLower) flags)- - strip :: String -> String- strip = dropWhile isSpace- - prep :: String -> String- prep = strip . drop 2 . strip- - fixC :: [CommentDecl] -> [CommentDecl]- fixC = map (\(c,d)->(map prep c,d))- - createFunction :: CommentDecl -> Function- createFunction (p,(TypeSig _ name' typ')) = Function name (tlength typ - 1) ty ann typ- where args = findStrings typ- t_name = head $ findStrings name'- typ = simplify typ'- (ann ,ty) = upgradeType noAnn typ- export = strip $ drop 6 $ head' $ filter ((=="export").map toLower.takeWhile (not.(\a->isSpace a || a=='='))) p- name = t_name-- createForeign :: Decl -> HaskellExport- createForeign (ForExp _ cc _ name ty) = HaskellExport (convert cc) noAnn (Export name' name' typ typ)- where convert Exts.StdCall = WinDll.Session.StdCall- convert Exts.CCall = WinDll.Session.CCall- - typ = simplify ty- name' = mkName name-- mkName (Exts.Ident s) = s- mkName (Exts.Symbol s) = s- - createExport :: CommentDecl -> Export- createExport (p,(TypeSig _ name' _type)) = Export name exportn ty typ- where t_name = head $ findStrings name'- (_ ,ty) = upgradeType noAnn typ- typ = simplify _type- export = strip $ drop 6 $ head' $ filter ((=="export").map toLower.takeWhile (not.(\a->isSpace a || a=='='))) p- exportn = if ("=" `isPrefixOf` export) then (takeWhile (not.isSpace).strip.tail) export else name- name = t_name- - head' :: [[a]] -> [a]- head' [] = []- head' (x:xs) = x- - createTypeSyn :: Decl -> WinDll.TypeDecL- createTypeSyn (TypeDecl _ name bind typ) = TypeDecL (head $ findStrings name) - (findStrings bind) (simplify typ)- - createDataType :: Decl -> WinDll.DataType- createDataType (DataDecl _ Exts.DataType _ name types constr _) = WinDll.DataType (head $ findStrings name) (findStrings types) (map (mkConstr (head $ findStrings name)) constr) NoTag- createDataType (DataDecl _ Exts.NewType _ name types constr _) = WinDll.NewType (head $ findStrings name) (findStrings types) (head $ map (mkConstr (head $ findStrings name)) constr) NoTag- - mkConstr str = (\(QualConDecl _ _ _ con)->case con of- (ConDecl cname vars) -> Constr xname (genFreeVars name 1 vars)- where name = let val = map toLower (str++"_"++xname++"_var")- in (val++)- xname = (head $ findStrings cname)- (RecDecl cname vars) -> Constr (head $ findStrings cname) (genNamedVars vars)- (InfixConDecl a name b) -> error "Parse error: Sorry, the current version of windll does not support infix constructor types.")- createInstance :: Decl -> WinDll.Instance- createInstance (InstDecl _ con name types decls)- = QualifiedInstance (head $ findStrings name) types- --- | Generate free variable names-genFreeVars :: (String -> String) -> Int -> [BangType] -> AnnNamedTypes-genFreeVars f _ [] = []-genFreeVars f n (x:xs) = let (ann, ty) = upgradeType noAnn t- t = getTypeFromBang x- name = (f.show) n- ann' = ann{ annArrayIsList = True, annArrayIndices = [] }- value = case isOnlyList t of- False -> AnnType name ty ann t- True -> AnnType name t ann' t- in value : genFreeVars f (n+1) xs- --- | Strip a layer away and get to the real type.-getTypeFromBang :: BangType -> WinDll.Type -getTypeFromBang (BangedTy t) = t-getTypeFromBang (UnBangedTy t) = t-getTypeFromBang (UnpackedTy t) = t- --- | Create elements of constructor for records.-genNamedVars :: Data b => [([b],BangType)] -> AnnNamedTypes-genNamedVars [] = [] -genNamedVars (((x:_),a):xs) = let (ann,val) = upgradeType noAnn ty- ann' = ann{ annArrayIsList = True, annArrayIndices = [] }- ty = getTypeFromBang a- name = head $ findStrings x- value = case isOnlyList ty of- False -> AnnType name val ann ty- True -> AnnType name ty ann' ty- in value : genNamedVars xs- --- | See if the type is just a list type-isOnlyList :: Exts.Type -> Bool-isOnlyList (Exts.TyParen a) = isOnlyList a-isOnlyList (Exts.TyList _) = True-isOnlyList _ = False- --- | Find all type strings, taking care to support things like type application-findTypeString :: Language.Haskell.Exts.Syntax.Type -> [String]-findTypeString (TyForall m c t ) = findTypeString t-findTypeString (TyFun t1 t2 ) = (findTypeString t1)++(findTypeString t2)-findTypeString (TyTuple b t ) = ["(" ++ foldr1 (\a b->a++","++b) (concatMap findTypeString t) ++ ")"]-findTypeString (TyList t ) = ["[" ++ unwords (findTypeString t) ++ "]"]-findTypeString (TyApp t1 t2 ) = [unwords (findTypeString t1 ++ findTypeString t2)]-findTypeString (TyVar n ) = findStrings' n-findTypeString (TyCon q ) = findStrings' q-findTypeString (TyParen p ) = ["(" ++ foldr1 (\a b->a++" -> "++b) (findTypeString p) ++ ")"]-findTypeString (TyInfix t1 q t2) = findTypeString t1 ++ findStrings' q ++- findTypeString t2-findTypeString (TyKind t k ) = findTypeString t---- | Rename the AST to not treat SpecialCons special but just as strings-renameAST :: Data a => a -> a-renameAST = everywhere (mkT inner)- where inner :: QName -> QName- inner (Special x) = UnQual (Symbol (mshow x))- inner x = x---- | Merge the specialized Type version along with the generic version-findStrings :: Data a => a -> [String]-findStrings = findStrings' -- `extQ` findTypeString).renameAST- --- | The SYB traversals do too much work, I need to figure out how to solve this. (it applies a matching function in both cases.-mkUnique :: [String] -> [String]-mkUnique x = filter condition x- where condition y = let y' = y ++ " "- y'' = ' ':y- y''' = (' ':y) ++ " "- in not (case y of- [] -> True- (o:_) -> any (\a->y' `isPrefixOf` a || y'' `isSuffixOf` a || y''' `isInfixOf` a) x)- --- | Upgrade a type by performing actions such as identifying list --- and changing the type to also pass along list counters-upgradeType :: Ann -> Exts.Type -> (Ann, Exts.Type)-upgradeType ann x = - let t' = updateType True ann' t- t = simplify x- lst' = findListIndices ty'- ann' = ann{annArrayIndices = lst'}- ty' = analyzeType True t'- in (ann', ty')- --- | Check to see if the last argument of the type is a list--- in which case we should change the Int before it to Ptr CInt-analyzeType :: Bool -> Exts.Type -> Exts.Type-analyzeType esc t =- let t' = everywhere (mkT embedded) t- lst = findListIndices t'- arr' = tlength t' - 1- part = arr' `elem` lst - ty' = if part - then changeType esc arr' (\val -> case val of- Exts.TyCon (Exts.UnQual (Exts.Ident "Int")) -> (Exts.TyApp - (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr")- (Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int"))- _ -> val) t'- else t'- in ty' -- D.trace ("IN: " ++ mshowM 2 t') $ D.trace ("OUT: " ++ mshowM 2 ty') $ D.trace (show arr' ++ " - " ++ show lst) ty'- where embedded :: Exts.Type -> Exts.Type- embedded (Exts.TyParen a) = (Exts.TyParen (analyzeType esc a))- embedded x = x- --- | Update the n-th element of the type with whatever we want-changeType :: Bool -> Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type-changeType _esc n f ty = fst $ (foldTypeIO alg ty) 0- where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int))- alg = (\a b c i -> let (c', i') = c i- in (Exts.TyForall a b c', i')- ,\a b i -> let (a', i' ) = a i- (b', i'') = b i'- in (Exts.TyFun a' b', i'')- ,\a b i -> let (b', i') = app b i- in (Exts.TyTuple a b', i)- ,\a i -> let (a', i') = a i- in (Exts.TyList a', i')- ,\o a b i -> let (a', i' ) = a i- (b', i'') = b i'- ix = if o then i'' else i'- in (Exts.TyApp a' b', ix) -- i'')- ,\a i -> let i' = i + 1- a' = Exts.TyVar a- in if i' == n - then (f a', i')- else (a' , i')- ,\a i -> let i' = i + 1- a' = Exts.TyCon a- in if i' == n - then (f a', i')- else (a' , i')- ,\a i -> let (a', i') = a i- in (Exts.TyParen a', i')- ,\a b c i -> let (a', i' ) = a i- (c', i'') = c i'- in (Exts.TyInfix a' b c', i'')- ,\a b i -> let (a', i') = a i- in (Exts.TyKind a' b, i')- )- app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int)- app [] i = ([], i)- app (x:xs) i = let (x' , i' ) = x i- (xs', i'') = app xs i'- in (x':xs', i'')- --- | Update a type according to the annotations present-updateType :: Bool -> Ann -> Exts.Type -> Exts.Type-updateType esc ann = everywhere (mkT pushType)- where -- | Types to update- pushType :: Exts.Type -> Exts.Type- pushType (Exts.TyFun a b) = let f x = case isIOList x of- True -> Exts.TyFun- (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int")- False -> id- g x = case isIOList x of- True -> Exts.TyFun - (Exts.TyApp - (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr")- (Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int"))- x- False -> x- in f a $ Exts.TyFun a (g b)- -- pushType (Exts.TyApp a b) = let f x = case isList x of- -- True -> Exts.TyFun- -- (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int") x- -- False -> x- -- in if isIO a - -- then simplify (move a $ f b)- -- else Exts.TyApp a b- pushType x = x- - -- | Move an IO declaration inwards.- move :: Exts.Type -> Exts.Type -> Exts.Type- move io (Exts.TyFun a b) = Exts.TyFun a (Exts.TyApp io b)- move io rest = Exts.TyApp io rest----- | Identifies locations within a Type where lists are found--- The indices provided are the locations of the size variables--- of arrays. The counters start at 0 and not 1 anymore.--- So keep this in mind :)-findListIndices :: Exts.Type -> [Int]-findListIndices ty = coords (embed ty) - where embed :: Exts.Type -> [Bool]- embed (Exts.TyFun a b) = let res = isList a- in if isFun b- then res:embed b- else res:[isIOList b]- embed (Exts.TyParen a) = embed a- embed _ = []- - coords :: [Bool] -> [Int]- coords b = [i | (x,i) <- zip b [(-1)..], x]- --- | A variant of isList that looks inside IO-isIOList :: Exts.Type -> Bool-isIOList (Exts.TyApp a b) = if isIO a - then isList b- else False-isIOList x = isList x- --- | Update the n-th element of the type with whatever we want,--- only looking at the amount of (->) constructors.-processTypeNode :: Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type-processTypeNode n f ty = fst $ (foldTypeIO alg ty) 1- where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int))- alg = (\a b c i -> let (c', i') = c i- in (Exts.TyForall a b c', i')- ,\a b i -> let (a', i' ) = a i- (b', i'') = b (i + 1)- value = Exts.TyFun (if i == n then f a' else a')- (if i+1 == n then f b' else b')- in (value , i'')- ,\a b i -> let (b', i') = app b i- in (Exts.TyTuple a b', i)- ,\a i -> let (a', i') = a i- in (Exts.TyList a', i')- ,\o a b i -> let (a', i' ) = a 0- (b', i'') = b 0- in (Exts.TyApp a' b', i)- ,\a i -> (Exts.TyVar a, i)- ,\a i -> (Exts.TyCon a, i)- ,\a i -> let (a', i') = a i- in (Exts.TyParen a', i')- ,\a b c i -> let (a', i' ) = a i- (c', i'') = c i'- in (Exts.TyInfix a' b c', i'')- ,\a b i -> let (a', i') = a i- in (Exts.TyKind a' b, i')- )- app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int)- app [] i = ([], i)- app (x:xs) i = let (x' , i' ) = x i- (xs', i'') = app xs i'- in (x':xs', i'')---- | Updates a type to that which uses IO-mkIO :: Exts.Type -> Exts.Type-mkIO ty = let arr = tlength ty- mk = simplify . Exts.TyApp (Exts.TyCon $ Exts.UnQual $ Exts.Ident "IO")- in if isIO ty - then ty- else if arr == 1 -- if there are no arguments, just directly apply mk- then mk ty- else processTypeNode arr mk ty---- | Checks to see if the function being returned is in IO-isIO :: Exts.Type -> Bool-isIO ty = let tys = collectLessTypes ty- ret = last tys- in "IO" `isPrefixOf` ret- --- simpleTest :: FilePath -> [CommentDecl]--- simpleTest path = let (m0, c0) = unsafePerformIO $ parseFromFile path- -- in matchFunctionsWithComments c0 (findTypeSignatures m0)- --- test :: IO WinDll.Module--- test = fmap (uncurry convertModule) (parseFromFile testFile)
+ WinDll/Parsers/Debug.hs view
@@ -0,0 +1,20 @@+ {-# LANGUAGE RelaxedPolyRec #-}++-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Parsers for the preprocessor. Parses using Haskell-src-exts +-- to the simple datatype in \WinDll.Structs.Structures\+-- These parsers are for the debug program+--+-----------------------------------------------------------------------------++module WinDll.Parsers.Debug where+
+ WinDll/Parsers/Hs2lib.hs view
@@ -0,0 +1,585 @@+ {-# LANGUAGE RelaxedPolyRec #-}++-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Parsers for the preprocessor. Parses using Haskell-src-exts +-- to the simple datatype in \WinDll.Structs.Structures\+-- These parsers are for the main program+--+-----------------------------------------------------------------------------++module WinDll.Parsers.Hs2lib where++import Language.Haskell.Exts+import Language.Haskell.Exts.Extension+import qualified Language.Haskell.Exts as Exts+import Language.Haskell.Exts.Parser+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Exts.Comments++import Data.Generics++import Data.IORef++import Data.List+import Data.Char+import Data.Maybe++import System.IO.Unsafe+import System.FilePath+import System.Directory++import Control.Monad++import WinDll.Structs.Structures hiding (Module)+import qualified WinDll.Structs.Structures as WinDll+import WinDll.Session.Hs2lib+import WinDll.Version.Hs2lib+import WinDll.Utils.Feedback+import WinDll.Structs.PrettyPrinting+import WinDll.Structs.MShow.HaskellSrcExts+import WinDll.Structs.MShow.MShow+import WinDll.Structs.Folds.HaskellSrcExts+import WinDll.Utils.Types++import qualified Debug.Trace as D++-- testFile = "C:\\Users\\Phyx\\Documents\\Haskell\\WinDLL\\test.hs"+testFile = "C:\\Users\\Phyx\\Documents\\Desktop\\native\\GHCDll.hs"++instance Num SrcLoc where+ (SrcLoc f l1 c1) - (SrcLoc _ l2 c2) = SrcLoc f (l1-l2) (c1-c2)+ (SrcLoc f l1 c1) + (SrcLoc _ l2 c2) = SrcLoc f (l1+l2) (c1+c2)+ (SrcLoc f l1 c1) * (SrcLoc _ l2 c2) = SrcLoc f (l1*l2) (c1*c2)+ abs (SrcLoc f l c) = SrcLoc f (abs l) (abs c)+ signum (SrcLoc f l c) = SrcLoc f (signum l) (signum c)+ fromInteger i = SrcLoc [] (fromInteger i) 0+ +-- instance Ord Decl where+ -- compare a b = if (a == b) then EQ else LT++-- | Read a file in, And store it in the list of \WinDll.Module\ and \WinDll.CodeGen.CommentDecl\+readFromFiles :: Exec ()+readFromFiles = + do session <- get+ inform _normal "Reading and parsing all dependencies..."+ let workset = workingset session+ paths <- liftIO $ mapM guessPath ((drop 1 (dependencies workset))++includes session) + (result, c0) <- liftM unzip $ forM (absPath session : paths) pdata+ put $ session { workingset = workset { modules = result+ , pragmas = catMaybes (parseComments (join c0)) } }+ where pdata :: FilePath -> Exec ((WinDll.Module, [CommentDecl]),[Comment])+ pdata path = + do (m0,c0) <- parseFromFile path+ inform _detail "Converting AST to internal representation..."+ moddata' <- convertModule m0 c0+ inform _detail "Updating module name..."+ let moddata = moddata' { header = (header moddata') { headername = reverse $ drop 1 $ dropWhile (/='.') $ reverse $ takeFileName path } }+ inform _detail "Matching and resolving comments..."+ let modcomment = matchFunctionsWithComments c0 (findTypeSignatures m0)+ inform _detail ("Finished processing " ++ path ++ "...\n")+ return ((moddata,modcomment), c0)+ + fixDependencies :: String -> FilePath+ fixDependencies current = let ldata = map (\a-> if a == '.' then pathSeparator else a) current+ fdata = ldata++".hs"+ in case unsafePerformIO (doesFileExist fdata) of+ True -> fdata+ False -> ldata ++ ".lhs"+ +-- | Convert the right comments to the correct pragmas. These are all globally scoped.+-- .+-- . supported pragmas are:+-- . {- @@ HS2LIB_OPTS <opts> @@ -} -=- turn on dynamic options present in this file+-- . {- @@ INSTANCE <name> <count> @@ -} -=- generate type info required to work correctly but also hides the warning of missing data definition+-- . {- @@ IMPORT <list> @@ -} -=- Imports to carry over to the new generated module+-- . {- @@ HS2C <htype> <type>@<size> @@ -} -=- Specifies what to translate the Haskell htype to the C type, but we also need its size in bytes+-- . {- @@ HS2C# <htype> <c#type> @@ -} -=- Specifies what to translate the Haskell htype to the C# type, but we also need its size in bytes+-- . {- @@ HS2HS <htype> <htype> @@ -} -=- Specifies what to translate the Haskell htype should be in terms of a compatible FFI type. +-- . There needs to be an FFIType instance for these types, or be covered by one of the defaults`+-- . +parseComments :: [Comment] -> [Maybe Pragma]+parseComments [] = []+parseComments ((Comment True _ s):xs) = f (trim s): parseComments xs+ where f :: String -> Maybe Pragma+ f s | "@@ " `isPrefixOf` s && " @@" `isSuffixOf` s = let stack = trim (drop 3 (take (length s - 3) s))+ (x:xs) = lexwords stack+ name = (map toUpper x)+ xs' = if name == (upper_name ++"_OPTS") then tail $ words stack else xs+ in if null stack then Nothing else Just (Pragma name xs')+ | otherwise = Nothing+ + trim :: String -> String+ trim = reverse . dropWhile (==' ') . reverse . dropWhile (==' ')+parseComments (_ :xs) = parseComments xs++lexwords :: String -> [String]+lexwords [] = []+lexwords str = let res = lex str+ (cur,rest) = head res+ cur' = case cur of+ [] -> []+ '"':xs -> init xs : lexwords rest+ '-':_ -> let other = lexwords rest+ (x:xs) = other+ in if null other then cur : other else (cur++x) : xs+ x -> x : lexwords rest+ in if null res then [] else cur'+ +-- | Parse a module from file while retaining comments+parseFromFile :: FilePath -> Exec (Module, [Comment])+parseFromFile path = + do inform _detail ("Parsing '" ++ path ++ "'")+ result <- liftIO $ parseFileWithComments (defaultParseMode { extensions = (TemplateHaskell:BangPatterns:NamedFieldPuns:ExplicitForall:glasgowExts), parseFilename = path }) path+ case result of+ (ParseOk a) -> return a+ (ParseFailed loc str) -> die (exename ++ " parse failure, reason: " ++ str ++ " at " ++ show loc)++-- | Finds all the type declarations from a given file.+findTypeSignatures :: Module -> [Decl]+findTypeSignatures = listify inner+ where inner (TypeSig _ _ _) = True+ inner _ = False++-- | Finds all the type synonym declarations from a given file.+findTypeDecl :: Module -> [Decl]+findTypeDecl = listify inner+ where inner (TypeDecl _ _ _ _) = True+ inner _ = False++-- | Finds all the foreign export declarations in a file+findForeignExports :: Module -> [Decl]+findForeignExports = listify inner+ where inner (ForExp _ _ _ _ _) = True+ inner _ = False+ +-- | Finds all the newtype or data declarations withing the given structure+findDataDeclarations :: Module -> [Decl]+findDataDeclarations = listify inner+ where inner (DataDecl _ _ _ _ _ _ _) = True+ inner _ = False+ +-- | Finds all the Storable instances declarations+findStorableDeclarations :: Module -> [Decl]+findStorableDeclarations = listify inner+ where inner (InstDecl _ _ name _ _ ) = "Storable" `elem` (findStrings name)+ inner _ = False+ +-- | Match function and comments to eachother and determine which comments indicate out special -- \@\@ comment flag+matchFunctionsWithComments :: [Comment] -> [Decl] -> [CommentDecl]+matchFunctionsWithComments comments decls = + let directives = filter (\t->"@@" `isPrefixOf` strip (readComment t)) comments+ in merge $ catMaybes $ map (matchDecl decls) (map convertComment directives)+ where readComment :: Comment -> String+ readComment (Comment _ _ s) = s+ + convertComment :: Comment -> MyComment+ convertComment (Comment _ l s) = MyComment l s+ + strip :: String -> String+ strip = dropWhile isSpace+ + maxScore :: Int+ maxScore = 500++ getScore :: SrcLoc -> Int+ getScore (SrcLoc _ l f) = if l > 0 then l else maxScore -- l*l + f*f+ + convertLoc :: SrcSpan -> SrcLoc+ convertLoc (SrcSpan n l f _ _) = SrcLoc n l f+ + matchDecl :: [Decl] -> MyComment -> Maybe CommentDecl+ matchDecl decls (MyComment l s) = + let ordered = sort $ map (\t@(TypeSig d _ _)->(getScore (d- (convertLoc l)),([s],t))) decls+ value = head ordered+ score = fst value+ in if score < maxScore then Just (snd value) else Nothing+ + merge :: [CommentDecl] -> [CommentDecl]+ merge [] = []+ merge x = map (foldr1 (\(a,_) (b,f)->(a++b,f))) $ groupBy (\a b->snd a==snd b) x+ +-- | Standard imports list for all generated moduels+stdImports :: Exec [Import]+stdImports = do session <- get+ let db = debugging session + return $ [ if db + then "WinDll.Lib.NativeMapping_Debug"+ else "WinDll.Lib.NativeMapping"+ ,if db + then "WinDll.Lib.Tuples_Debug"+ else "WinDll.Lib.Tuples"+ ,"WinDll.Lib.InstancesTypes"+ ,if db + then "Foreign hiding (free, malloc, alloca, realloc)"+ else "Foreign"+ ,"Foreign.C"+ ,"Foreign.C.Types"+ ,"Foreign.Ptr"+ ,if db+ then "WinDll.Debug.Alloc"+ else "Foreign.Marshal.Alloc"+ ,"Foreign.Marshal.Utils"+ ,"Foreign.ForeignPtr"+ ] ++ if db + then ["WinDll.Debug.Stack"+ ,"qualified WinDll.Debug.Exports as Ex"+ ] + else []+ +-- | Convert the parsed Haskell-src-exts to the internal Module definition.+-- A nother limitation to get this done on time, is that i don't support infix constructors+convertModule :: Module -> [Comment] -> Exec WinDll.Module+convertModule m@(Module (SrcLoc file _ _) (ModuleName modname) _ _ _ _ decl) comments = + let header = Header modname []+ exports = map createExport t_func+ datatypes = map createDataType t_data+ functions = map createFunction t_func+ tdecl = map createTypeSyn t_type+ instances = map createInstance t_inst+ foreigns = map createForeign t_fexpr+ + t_func = filter isExport $ fixC $ matchFunctionsWithComments comments (findTypeSignatures m)+ t_data = findDataDeclarations m+ t_type = findTypeDecl m+ t_inst = findStorableDeclarations m+ t_fexpr = findForeignExports m+ + in do session <- get+ let workset = workingset session+ newset = workset { n_exports = n_exports workset ++ foreigns }+ newsess = session { workingset = newset }+ put newsess+ stdi <- stdImports+ return $ WinDll.Module header file (("@"++modname):stdi) exports datatypes functions instances tdecl+ where isExport :: CommentDecl -> Bool+ isExport (flags, _) = any (isPrefixOf "export") (map (map toLower) flags)+ + strip :: String -> String+ strip = dropWhile isSpace+ + prep :: String -> String+ prep = strip . drop 2 . strip+ + fixC :: [CommentDecl] -> [CommentDecl]+ fixC = map (\(c,d)->(map prep c,d))+ + createFunction :: CommentDecl -> Function+ createFunction (p,(TypeSig _ name' typ')) = Function name (tlength typ - 1) ty ann typ+ where args = findStrings typ+ t_name = head $ findStrings name'+ typ = simplify typ'+ (ann ,ty) = upgradeType newAnn typ+ export = strip $ drop 6 $ head' $ filter ((=="export").map toLower.takeWhile (not.(\a->isSpace a || a=='='))) p+ name = t_name++ createForeign :: Decl -> HaskellExport+ createForeign (ForExp _ cc _ name ty) = HaskellExport (convert cc) newAnn (Export name' name' typ typ modname)+ where convert Exts.StdCall = WinDll.Session.Hs2lib.StdCall+ convert Exts.CCall = WinDll.Session.Hs2lib.CCall+ + typ = simplify ty+ name' = mkName name++ mkName (Exts.Ident s) = s+ mkName (Exts.Symbol s) = s+ + createExport :: CommentDecl -> Export+ createExport (p,(TypeSig _ name' _type)) = Export name exportn ty typ modname+ where t_name = head $ findStrings name'+ (_ ,ty) = upgradeType newAnn typ+ typ = simplify _type+ export = strip $ drop 6 $ head' $ filter ((=="export").map toLower.takeWhile (not.(\a->isSpace a || a=='='))) p+ exportn = if ("=" `isPrefixOf` export) then (takeWhile (not.isSpace).strip.tail) export else name+ name = t_name+ + head' :: [[a]] -> [a]+ head' [] = []+ head' (x:xs) = x+ + newAnn = noAnn { annModule = modname }+ + createTypeSyn :: Decl -> WinDll.TypeDecL+ createTypeSyn (TypeDecl _ name bind typ) = TypeDecL (head $ findStrings name) + (findStrings bind) (simplify typ)+ + createDataType :: Decl -> WinDll.DataType+ createDataType (DataDecl _ Exts.DataType _ name types constr _) = WinDll.DataType (head $ findStrings name) (findStrings types) (map (mkConstr (head $ findStrings name)) constr) NoTag+ createDataType (DataDecl _ Exts.NewType _ name types constr _) = WinDll.NewType (head $ findStrings name) (findStrings types) (head $ map (mkConstr (head $ findStrings name)) constr) NoTag+ + mkConstr str = (\(QualConDecl _ _ _ con)->case con of+ (ConDecl cname vars) -> Constr xname Normal (genFreeVars modname name 1 vars)+ where name = let val = map toLower (str++"_"++xname++"_var")+ in (val++)+ xname = (head $ findStrings cname)+ (RecDecl cname vars) -> Constr (head $ findStrings cname) Normal (genNamedVars modname vars)+ (InfixConDecl a name b) -> error "Parse error: Sorry, the current version of windll does not support infix constructor types.")+ createInstance :: Decl -> WinDll.Instance+ createInstance (InstDecl _ con name types decls)+ = QualifiedInstance (head $ findStrings name) types+ +-- | Generate free variable names+genFreeVars :: WinDll.ModuleName -> (String -> String) -> Int -> [BangType] -> AnnNamedTypes+genFreeVars nm f _ [] = []+genFreeVars nm f n (x:xs) = let (ann, ty) = upgradeType noAnn t+ t = getTypeFromBang x+ name = (f.show) n+ ann' = ann{ annArrayIsList = True, annArrayIndices = [], annModule = nm }+ value = case isOnlyList t of+ False -> AnnType name ty ann t nm+ True -> AnnType name t ann' t nm+ in value : genFreeVars nm f (n+1) xs+ +-- | Strip a layer away and get to the real type.+getTypeFromBang :: BangType -> WinDll.Type +getTypeFromBang (BangedTy t) = t+getTypeFromBang (UnBangedTy t) = t+getTypeFromBang (UnpackedTy t) = t+ +-- | Create elements of constructor for records.+genNamedVars :: Data b => WinDll.ModuleName -> [([b],BangType)] -> AnnNamedTypes+genNamedVars _ [] = [] +genNamedVars n (((x:_),a):xs) = let (ann,val) = upgradeType noAnn ty+ ann' = ann{ annArrayIsList = True, annArrayIndices = [], annModule = n }+ ty = getTypeFromBang a+ name = head $ findStrings x+ value = case isOnlyList ty of+ False -> AnnType name val ann ty n+ True -> AnnType name ty ann' ty n+ in value : genNamedVars n xs+ +-- | See if the type is just a list type+isOnlyList :: Exts.Type -> Bool+isOnlyList (Exts.TyParen a) = isOnlyList a+isOnlyList (Exts.TyList _) = True+isOnlyList _ = False+ +-- | Find all type strings, taking care to support things like type application+findTypeString :: Language.Haskell.Exts.Syntax.Type -> [String]+findTypeString (TyForall m c t ) = findTypeString t+findTypeString (TyFun t1 t2 ) = (findTypeString t1)++(findTypeString t2)+findTypeString (TyTuple b t ) = ["(" ++ foldr1 (\a b->a++","++b) (concatMap findTypeString t) ++ ")"]+findTypeString (TyList t ) = ["[" ++ unwords (findTypeString t) ++ "]"]+findTypeString (TyApp t1 t2 ) = [unwords (findTypeString t1 ++ findTypeString t2)]+findTypeString (TyVar n ) = findStrings' n+findTypeString (TyCon q ) = findStrings' q+findTypeString (TyParen p ) = ["(" ++ foldr1 (\a b->a++" -> "++b) (findTypeString p) ++ ")"]+findTypeString (TyInfix t1 q t2) = findTypeString t1 ++ findStrings' q +++ findTypeString t2+findTypeString (TyKind t k ) = findTypeString t++-- | Rename the AST to not treat SpecialCons special but just as strings+renameAST :: Data a => a -> a+renameAST = everywhere (mkT inner)+ where inner :: QName -> QName+ inner (Special x) = UnQual (Symbol (mshow x))+ inner x = x++-- | Merge the specialized Type version along with the generic version+findStrings :: Data a => a -> [String]+findStrings = findStrings' -- `extQ` findTypeString).renameAST+ +-- | The SYB traversals do too much work, I need to figure out how to solve this. (it applies a matching function in both cases.+mkUnique :: [String] -> [String]+mkUnique x = filter condition x+ where condition y = let y' = y ++ " "+ y'' = ' ':y+ y''' = (' ':y) ++ " "+ in not (case y of+ [] -> True+ (o:_) -> any (\a->y' `isPrefixOf` a || y'' `isSuffixOf` a || y''' `isInfixOf` a) x)+ +-- | Upgrade a type by performing actions such as identifying list +-- and changing the type to also pass along list counters+upgradeType :: Ann -> Exts.Type -> (Ann, Exts.Type)+upgradeType ann x = + let t' = updateType True ann' t+ t = simplify x+ lst' = findListIndices ty'+ ann' = ann{annArrayIndices = lst'}+ ty' = analyzeType True t'+ in (ann', ty')+ +-- | Check to see if the last argument of the type is a list+-- in which case we should change the Int before it to Ptr CInt+analyzeType :: Bool -> Exts.Type -> Exts.Type+analyzeType esc t =+ let t' = everywhere (mkT embedded) t+ lst = findListIndices t'+ arr' = tlength t' - 1+ part = arr' `elem` lst + ty' = if part + then changeType esc arr' (\val -> case val of+ Exts.TyCon (Exts.UnQual (Exts.Ident "Int")) -> (Exts.TyApp + (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr")+ (Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int"))+ _ -> val) t'+ else t'+ in ty' -- D.trace ("IN: " ++ mshowM 2 t') $ D.trace ("OUT: " ++ mshowM 2 ty') $ D.trace (show arr' ++ " - " ++ show lst) ty'+ where embedded :: Exts.Type -> Exts.Type+ embedded (Exts.TyParen a) = (Exts.TyParen (analyzeType esc a))+ embedded x = x+ +-- | Update the n-th element of the type with whatever we want+changeType :: Bool -> Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type+changeType _esc n f ty = fst $ (foldTypeIO alg ty) 0+ where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int))+ alg = (\a b c i -> let (c', i') = c i+ in (Exts.TyForall a b c', i')+ ,\a b i -> let (a', i' ) = a i+ (b', i'') = b i'+ in (Exts.TyFun a' b', i'')+ ,\a b i -> let (b', i') = app b i+ in (Exts.TyTuple a b', i)+ ,\a i -> let (a', i') = a i+ in (Exts.TyList a', i')+ ,\o a b i -> let (a', i' ) = a i+ (b', i'') = b i'+ ix = if o then i'' else i'+ in (Exts.TyApp a' b', ix) -- i'')+ ,\a i -> let i' = i + 1+ a' = Exts.TyVar a+ in if i' == n + then (f a', i')+ else (a' , i')+ ,\a i -> let i' = i + 1+ a' = Exts.TyCon a+ in if i' == n + then (f a', i')+ else (a' , i')+ ,\a i -> let (a', i') = a i+ in (Exts.TyParen a', i')+ ,\a b c i -> let (a', i' ) = a i+ (c', i'') = c i'+ in (Exts.TyInfix a' b c', i'')+ ,\a b i -> let (a', i') = a i+ in (Exts.TyKind a' b, i')+ )+ app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int)+ app [] i = ([], i)+ app (x:xs) i = let (x' , i' ) = x i+ (xs', i'') = app xs i'+ in (x':xs', i'')+ +-- | Update a type according to the annotations present+updateType :: Bool -> Ann -> Exts.Type -> Exts.Type+updateType esc ann = everywhere (mkT pushType)+ where -- | Types to update+ pushType :: Exts.Type -> Exts.Type+ pushType (Exts.TyFun a b) = let f x = case isIOList x of+ True -> Exts.TyFun+ (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int")+ False -> id+ g x = case isIOList x of+ True -> Exts.TyFun + (Exts.TyApp + (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr")+ (Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int"))+ x+ False -> x+ in f a $ Exts.TyFun a (g b)+ -- pushType (Exts.TyApp a b) = let f x = case isList x of+ -- True -> Exts.TyFun+ -- (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int") x+ -- False -> x+ -- in if isIO a + -- then simplify (move a $ f b)+ -- else Exts.TyApp a b+ pushType x = x+ + -- | Move an IO declaration inwards.+ move :: Exts.Type -> Exts.Type -> Exts.Type+ move io (Exts.TyFun a b) = Exts.TyFun a (Exts.TyApp io b)+ move io rest = Exts.TyApp io rest+++-- | Identifies locations within a Type where lists are found+-- The indices provided are the locations of the size variables+-- of arrays. The counters start at 0 and not 1 anymore.+-- So keep this in mind :)+findListIndices :: Exts.Type -> [Int]+findListIndices ty = coords (embed ty) + where embed :: Exts.Type -> [Bool]+ embed (Exts.TyFun a b) = let res = isList a+ in if isFun b+ then res:embed b+ else res:[isIOList b]+ embed (Exts.TyParen a) = embed a+ embed _ = []+ + coords :: [Bool] -> [Int]+ coords b = [i | (x,i) <- zip b [(-1)..], x]+ +-- | A variant of isList that looks inside IO+isIOList :: Exts.Type -> Bool+isIOList (Exts.TyApp a b) = if isIO a + then isList b+ else False+isIOList x = isList x+ +-- | Update the n-th element of the type with whatever we want,+-- only looking at the amount of (->) constructors.+processTypeNode :: Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type+processTypeNode n f ty = fst $ (foldTypeIO alg ty) 1+ where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int))+ alg = (\a b c i -> let (c', i') = c i+ in (Exts.TyForall a b c', i')+ ,\a b i -> let (a', i' ) = a i+ (b', i'') = b (i + 1)+ value = Exts.TyFun (if i == n then f a' else a')+ (if i+1 == n then f b' else b')+ in (value , i'')+ ,\a b i -> let (b', i') = app b i+ in (Exts.TyTuple a b', i)+ ,\a i -> let (a', i') = a i+ in (Exts.TyList a', i')+ ,\o a b i -> let (a', i' ) = a 0+ (b', i'') = b 0+ in (Exts.TyApp a' b', i)+ ,\a i -> (Exts.TyVar a, i)+ ,\a i -> (Exts.TyCon a, i)+ ,\a i -> let (a', i') = a i+ in (Exts.TyParen a', i')+ ,\a b c i -> let (a', i' ) = a i+ (c', i'') = c i'+ in (Exts.TyInfix a' b c', i'')+ ,\a b i -> let (a', i') = a i+ in (Exts.TyKind a' b, i')+ )+ app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int)+ app [] i = ([], i)+ app (x:xs) i = let (x' , i' ) = x i+ (xs', i'') = app xs i'+ in (x':xs', i'')++-- | Updates a type to that which uses IO+mkIO :: Exts.Type -> Exts.Type+mkIO ty = let arr = tlength ty+ mk = simplify . Exts.TyApp (Exts.TyCon $ Exts.UnQual $ Exts.Ident "IO")+ in if isIO ty + then ty+ else if arr == 1 -- if there are no arguments, just directly apply mk+ then mk ty+ else processTypeNode arr mk ty++-- | Checks to see if the function being returned is in IO+isIO :: Exts.Type -> Bool+isIO ty = let tys = collectLessTypes ty+ ret = last tys+ in "IO" `isPrefixOf` ret+ +-- simpleTest :: FilePath -> [CommentDecl]+-- simpleTest path = let (m0, c0) = unsafePerformIO $ parseFromFile path+ -- in matchFunctionsWithComments c0 (findTypeSignatures m0)+ +-- test :: IO WinDll.Module+-- test = fmap (uncurry convertModule) (parseFromFile testFile)
− WinDll/Session.hs
@@ -1,248 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}--------------------------------------------------------------------------------- |--- Module : Windll--- Copyright : (c) Tamar Christina 2009 - 2010--- License : BSD3--- --- Maintainer : tamar@zhox.com--- Stability : experimental--- Portability : portable------ Session management information and global state modifiers-----------------------------------------------------------------------------------module WinDll.Session (module WinDll.Session- ,module Control.Monad.State) where--import Control.Monad.State-import Control.Monad.Trans-import Control.Monad.Error-import Control.Monad--import System.Directory-import System.IO.Unsafe--import WinDll.Structs.Structures-import WinDll.Structs.Types-import WinDll.Structs.PrettyPrinting-import WinDll.Version--import qualified Language.Haskell.Exts.Syntax as Exts--import Data.Either-import Data.Data-import Data.Char-import Data.Generics-import Data.Monoid--import GHC.Paths ( libdir )-import GHC (guessTarget, targetId, TargetId(..), runGhc)-import Module(moduleNameSlashes)-import System.IO.Unsafe (unsafePerformIO)--import Debug.Trace(trace)---- | Calling Convention for the exported module-data CallConvention = StdCall -- ^ Windows StdCall- | CCall -- ^ Standard C call- deriving (Show,Eq,Read,Data,Typeable)---- | Export statements fully qualified-data HaskellExport = HaskellExport CallConvention Ann Export- deriving(Eq,Show,Data,Typeable)- --- | Import statements fully qualified-data HaskellImport = HaskellImport CallConvention Ann Export- deriving(Eq,Show,Data,Typeable)- --- | Create an empty Ann with the list in workingset filled in-makeSessionAnn :: Exec Ann-makeSessionAnn = do session <- fmap workingset get - return $ mempty { annWorkingSet = n_hs2hs session- , annWorkingSetC = n_hs2c session- , annWorkingSetCSize = n_csize session- , annWorkingSetCs = n_hs2cs session- }- --- | Convert the Internal type to c types in the windef.h in mingw-genCcall :: CallConvention -> String-genCcall StdCall = "StdCall"-genCcall CCall = "CDECL"---- | Check is whatever it is was passed as an argument contains a TyFun (->) -gIsFun :: GenericQ Bool-gIsFun = or . gmapQ (False `mkQ` isFun)- where isFun (Exts.TyFun{}) = True- isFun _ = False- --- | Conditionally add parenthesis to the type, if it doesn't have any to begin with-addParen :: Type -> Type-addParen x@(Exts.TyParen _) = x-addParen x | gIsFun x = Exts.TyParen x-addParen x@(Exts.TyFun{}) = Exts.TyParen x-addParen x = x---- | The platform your compiling for, This determines the type of library that is created.-data Platform = Windows -- ^ Windows DLL- | Unix -- ^ Lib files- deriving (Show,Eq,Read)- --- | Contains the enviroment settings, e.g. path to ghc,hsc2hs etc-data EnvPaths = EnvPaths---- | Simple flags, used with GetOpt-data Options = Version | Help- deriving (Show,Eq)- --- | Global session management information passed through each function -data Session = Session { mainFile :: String -- ^ @mainFile @ Main filename- , absPath :: String -- ^ @absPath@ The absolute path to the main file- , verbosity :: Int -- ^ @verbosity@ debugging verbosity level- , call :: CallConvention -- ^ @call@ The calling convention to use when exporting functions- , namespace :: String -- ^ @namespace@ default namespace for c# codegen- , csharp :: Bool -- ^ @csharp@ generate c# code- , cpp :: Bool -- ^ @cpp@ generate c/c++ code- , mvcpp :: Bool -- ^ @mvcpp@ Generate the .LIB file for when linking with the microsoft vc++ compiler.- , incDef :: Bool -- ^ @incDef@ Copy the generated .DEF file also to the specified output folder- , link_dynamic :: Bool -- ^ @link_dynamic@ Link the files using dynamic linking if possible.- , pres_comment :: Bool -- ^ @pres_comment@ Enables Haddock comment preservation in the generated _FFI.c file- , hackage_list :: String -- ^ @hackage_list@ Hackage packages url- , hackage_base_url :: String -- ^ @hackage_base_url@ The base url of hackage- , hackage_src_url :: String -- ^ @hackage_src_url@ What to append to the hackage url to get source- , warnings :: Bool -- ^ @warnings@ Check if warnings should be printed- , warnings_as_errors :: Bool -- ^ @warnings_as_errors@ Treat warnings as errors - , outputDIR :: String -- ^ @outputDir@ Redirect output to a folder- , baseDir :: String -- ^ @baseDir@ Path to the base folder which contains the WinDll includes folder and template folder- , tempDIR :: String -- ^ @tempDir@ Set the temporary folder to use- , keep_temps :: Bool -- ^ @keep_temps@ Keep temporary files- , outputFile :: String -- ^ @outputFile@ The output fill name- , platform :: Platform -- ^ @platform@ The platform to compile for- , dllmain :: FilePath -- ^ @dllmain@ The path to the lib main file to use- , dllmanual :: Bool -- ^ @dllmanual@ Indicates that you want to manually initialize the RTS. @dllmain@ will be ignored.- , threaded :: Bool -- ^ @threaded@ Compile the lib using the threaded RTS. this implies dllmanual- , options :: [Options] -- ^ @options@ The none executable flags- , includes :: [FilePath] -- ^ @includes@ The list of extra source files to include with data definitions- , workingset :: WorkingSet -- ^ @workingset@ The current working set for the project- , pipeline :: Builder -- ^ @pipeline@ Contains cleanup information needed when program is exiting- , include_foreigns :: Bool -- ^ @include_foreigns@ re-expose foreign declarations found when analyzing modules.- , native_symbols :: [FilePath] -- ^ @native_symbols@ The list of Native Symbols to include in the generated .DEF files.- }- deriving Show- --- | Datatype that hold the information needed by the different components of the preprocessor-data WorkingSet = WorkingSet { dependencies :: [String] -- ^ @dependencies@ Module dependencies, Othe source files to traverse- , modules :: [(Module, [CommentDecl])] -- ^ @modules@ A list of modules matched with their function comments, this is done before hand to save some time.- , entrypoint :: String -- ^ @entrypoint@ The main entry point for the dll, will be generated based on the top dll given.- , pragmas :: [Pragma] -- ^ @pramas@ Program wide control pragmas- , n_exports :: [HaskellExport] -- ^ @n_exports@ the list of haskell exports found inside parsed modules. This gets populated when \include_foreigns\ is true.- , n_hs2c :: [(String, String)] -- ^ @n_hs2c@ supplimentary list of conversions of Haskell to C, user provided- , n_csize :: [(String, Int )] -- ^ @n_csize@ supplimentary list of C sizes, user provided- , n_hs2cs :: Bool -> [(String, String)] -- ^ @n_hs2cs@ supplimentary list of conversions of Haskell to C#, user provided- , n_hs2hs :: [(String, String)] -- ^ @n_hs2hs@ supplimentary list of conversions of Haskell to HSC, user provided- }- deriving Show- --- | DataType to hold all the filed we've build during the compilation phase in order to clean them up at the end-data Builder = Builder { files :: [FilePath] -- ^ @files@ The list of files compiled during the build phase.- , dirPath :: FilePath -- ^ @dirPath@ The real directory to write in.- , mergeDep :: Maybe ModInfo -- ^ @mergeDep@ Cached merged dependency tree. to prevent repeated recalculations- , specs :: [(Name,Types)] -- ^ @specs@ Datatypes that need to be specialized.- } deriving Show- --- | Contains the desugared processed module information-data ModInfo = ModInfo { modFunctions :: [Function] -- ^ @modFunctions@ Functions which are to be exported by FFI- , modDatatypes :: (DataTypes, DataTypes) -- ^ @modDatatypes@ A tuple of (simple datatypes, dataypes to be specialized)- , modExports :: [Export] -- ^ @modExports@ A list of exports generated from the functions- , modCallbacks :: [Callback] -- ^ @modCallbacks@ The Haskell Callbacks generated from the exports and datatypes- , modStablePtrs :: [Stable] -- ^ @modCallbacks@ The Haskell Callbacks generated from the exports and datatypes- } deriving Show- --- | Monad transformer used to do all computations in -type Exec a = StateT Session (ErrorT String IO) a---- | Make the Either a Monad instance --- instance Monad (Either String) where- -- fail str = Left str- -- return a = Right a- -- (Left str ) >>= _ = Left str- -- (Right a) >>= f = f a- --- | And also make the Either a Functor-instance Functor (Either String) where- fmap f (Left str) = Left str- fmap f (Right a) = Right (f a)---- | And a MonadPlus instance-instance MonadPlus (Either String) where- mzero = Left ""- (Left _) `mplus` xs = xs- xs `mplus` ys = xs- --- | MonadIO instance so that liftIO can be used inside the StateT--- instance MonadIO (Either String) where- -- liftIO = (($!) return) . unsafePerformIO ---- | The default session initialized to the values specific for windows-newSession = Session { mainFile = ""- , absPath = ""- , verbosity = 0- , call = StdCall- , namespace = exename- , csharp = False- , cpp = True- , mvcpp = False- , incDef = False- , link_dynamic = False- , pres_comment = True- , include_foreigns = True- , hackage_base_url = "http://hackage.haskell.org/packages/archive/"- , hackage_list = "00-index.tar.gz"- , hackage_src_url = "/latest/doc/html/src"- , warnings = True- , warnings_as_errors = False- , outputDIR = "."- , baseDir = unsafePerformIO getCurrentDirectory- , tempDIR = unsafePerformIO getTemporaryDirectory- , keep_temps = False- , outputFile = []- , platform = Windows- , dllmain = []- , dllmanual = True- , threaded = False- , options = []- , includes = []- , native_symbols = []- , workingset = WorkingSet { dependencies = []- , modules = [] - , entrypoint = []- , pragmas = []- , n_exports = []- , n_hs2c = []- , n_csize = []- , n_hs2cs = const []- , n_hs2hs = []- }- , pipeline = Builder { files = []- , dirPath = []- , mergeDep = Nothing- , specs = []- }- }---- | Guess the fullname of a target file-guessPath :: FilePath -> FilePath-guessPath mangled = unsafePerformIO $ - runGhc (Just libdir) $ - do target <- guessTarget mangled Nothing- case targetId target of- (TargetModule m) -> do let name = moduleNameSlashes m- -- unsafePerformIO shouldn't be needed. There is an instance of MonadIO for GHC in - -- HscTypes, however, ghc for some reason can't find it. And it's bitching too much.- exist = unsafePerformIO $ doesFileExist (name ++ ".hs") - case exist of- True -> return $ name ++ ".hs"- False -> return $ name ++ ".lhs"- (TargetFile path _) -> return path
+ WinDll/Session/Debug.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Session management information and global state modifiers for the +-- debug program.+--+-----------------------------------------------------------------------------++module WinDll.Session.Debug (module WinDll.Session.Debug+ ,module Control.Monad.State.Strict) where++import Control.Monad.State.Strict+import Control.Monad.Trans+import Control.Monad.Error+import Control.Monad++import System.Directory+import System.IO.Unsafe+import System.FilePath++import WinDll.Version.Debug+import WinDll.Debug.Records ( fileName, MemAlloc )+import {-# SOURCE #-} WinDll.Debug.Heap ( Heap(..) )++import Data.Either+import Data.Data+import Data.Char+import Data.Generics+import Data.Monoid++import GHC.Paths ( libdir )+import GHC (guessTarget, targetId, TargetId(..), runGhc)+import Module(moduleNameSlashes)++import Debug.Trace(trace)+ +-- | The platform your compiling for, This determines the type of library that is created.+data Platform = Windows -- ^ Windows DLL+ | Unix -- ^ Lib files+ deriving (Show,Eq,Read)+ +-- | Contains the enviroment settings, e.g. path to ghc,hsc2hs etc+data EnvPaths = EnvPaths++-- | Simple flags, used with GetOpt+data Options = Version | Help+ deriving (Show,Eq)+ +-- | Global session management information passed through each function +data Session = Session { mainFile :: String -- ^ @mainFile @ Main filename+ , absPath :: String -- ^ @absPath@ The absolute path to the main file+ , verbosity :: Int -- ^ @verbosity@ debugging verbosity level + , outputDIR :: String -- ^ @outputDir@ Redirect output to a folder+ , baseDir :: String -- ^ @baseDir@ Path to the base folder which contains the WinDll includes folder and template + , outputFile :: String -- ^ @outputFile@ The output file name+ , platform :: Platform -- ^ @platform@ The platform to compile for+ , options :: [Options] -- ^ @options@ The none executable flags+ , memAllocs :: [MemAlloc] -- ^ @memAllocs@ The list of memory allocations that we're processing+ , memAllocsLen :: Int -- ^ @memAllocs@ The amount of allocations to process+ , heap :: Heap+ }+ deriving Show+ +-- | Monad transformer used to do all computations in +type Exec a = StateT Session (ErrorT String IO) a++-- | Make the Either a Monad instance +-- instance Monad (Either String) where+ -- fail str = Left str+ -- return a = Right a+ -- (Left str ) >>= _ = Left str+ -- (Right a) >>= f = f a+ +-- | And also make the Either a Functor+instance Functor (Either String) where+ fmap f (Left str) = Left str+ fmap f (Right a) = Right (f a)++-- | And a MonadPlus instance+instance MonadPlus (Either String) where+ mzero = Left ""+ (Left _) `mplus` xs = xs+ xs `mplus` ys = xs+ +-- | MonadIO instance so that liftIO can be used inside the StateT+-- instance MonadIO (Either String) where+ -- liftIO = (($!) return) . unsafePerformIO ++-- | The default session initialized to the values specific for windows+newSession = Session { mainFile = ""+ , absPath = ""+ , verbosity = 0+ , outputDIR = "."+ , baseDir = []+ , outputFile = []+ , platform = Windows+ , options = []+ , memAllocs = []+ , memAllocsLen = 0+ , heap = NoHeap+ }++-- | Guess the fullname of a target file+guessPath :: FilePath -> IO FilePath+guessPath mangled = do fn <- fileName+ let file = takeFileName fn+ fullname1 = mangled </> fn+ fullname2 = mangled </> file+ exists1 <- doesFileExist fullname1+ exists2 <- doesFileExist fullname2+ case (exists1, exists2) of + (True, _) -> return fullname1+ (_ , True) -> return fullname2+ (_ , _) -> error $ "Could not find '" ++ file ++ "' in the specified location"
+ WinDll/Session/Hs2lib.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Session management information and global state modifiers for+-- the main program+--+-----------------------------------------------------------------------------++module WinDll.Session.Hs2lib (module WinDll.Session.Hs2lib+ ,module Control.Monad.State) where++import Control.Monad.State+import Control.Monad.Trans+import Control.Monad.Error+import Control.Monad++import System.Directory+import System.IO.Unsafe++import WinDll.Structs.Structures+import WinDll.Structs.Types+import WinDll.Structs.PrettyPrinting+import WinDll.Version.Hs2lib++import qualified Language.Haskell.Exts.Syntax as Exts++import Data.Either+import Data.Data+import Data.Char+import Data.Generics+import Data.Monoid++import GHC.Paths ( libdir )+import GHC (guessTarget, targetId, TargetId(..), runGhc)+import Module(moduleNameSlashes)+import System.IO.Unsafe (unsafePerformIO)++import Debug.Trace(trace)++-- | Calling Convention for the exported module+data CallConvention = StdCall -- ^ Windows StdCall+ | CCall -- ^ Standard C call+ deriving (Show,Eq,Read,Data,Typeable)++-- | Export statements fully qualified+data HaskellExport = HaskellExport CallConvention Ann Export+ deriving(Eq,Show,Data,Typeable)+ +-- | Import statements fully qualified+data HaskellImport = HaskellImport CallConvention Ann Export+ deriving(Eq,Show,Data,Typeable)+ +-- | Create an empty Ann with the list in workingset filled in+makeSessionAnn :: Exec Ann+makeSessionAnn = do session <- fmap workingset get + debug <- fmap debugging get+ return $ mempty { annWorkingSet = n_hs2hs session+ , annWorkingSetC = n_hs2c session+ , annWorkingSetCSize = n_csize session+ , annWorkingSetCs = n_hs2cs session+ , annDebug = debug+ }+ +-- | Convert the Internal type to c types in the windef.h in mingw+genCcall :: CallConvention -> String+genCcall StdCall = "StdCall"+genCcall CCall = "CDECL"++-- | Check is whatever it is was passed as an argument contains a TyFun (->) +gIsFun :: GenericQ Bool+gIsFun = or . gmapQ (False `mkQ` isFun)+ where isFun (Exts.TyFun{}) = True+ isFun _ = False+ +-- | Conditionally add parenthesis to the type, if it doesn't have any to begin with+addParen :: Type -> Type+addParen x@(Exts.TyParen _) = x+addParen x | gIsFun x = Exts.TyParen x+addParen x@(Exts.TyFun{}) = Exts.TyParen x+addParen x = x++-- | The platform your compiling for, This determines the type of library that is created.+data Platform = Windows -- ^ Windows DLL+ | Unix -- ^ Lib files+ deriving (Show,Eq,Read)+ +-- | Contains the enviroment settings, e.g. path to ghc,hsc2hs etc+data EnvPaths = EnvPaths++-- | Simple flags, used with GetOpt+data Options = Version | Help+ deriving (Show,Eq)+ +-- | Global session management information passed through each function +data Session = Session { mainFile :: String -- ^ @mainFile @ Main filename+ , absPath :: String -- ^ @absPath@ The absolute path to the main file+ , verbosity :: Int -- ^ @verbosity@ debugging verbosity level+ , call :: CallConvention -- ^ @call@ The calling convention to use when exporting functions+ , namespace :: String -- ^ @namespace@ default namespace for c# codegen+ , csharp :: Bool -- ^ @csharp@ generate c# code+ , cpp :: Bool -- ^ @cpp@ generate c/c++ code+ , mvcpp :: Bool -- ^ @mvcpp@ Generate the .LIB file for when linking with the microsoft vc++ compiler.+ , incDef :: Bool -- ^ @incDef@ Copy the generated .DEF file also to the specified output folder+ , link_dynamic :: Bool -- ^ @link_dynamic@ Link the files using dynamic linking if possible.+ , pres_comment :: Bool -- ^ @pres_comment@ Enables Haddock comment preservation in the generated _FFI.c file+ , hackage_list :: String -- ^ @hackage_list@ Hackage packages url+ , hackage_base_url :: String -- ^ @hackage_base_url@ The base url of hackage+ , hackage_src_url :: String -- ^ @hackage_src_url@ What to append to the hackage url to get source+ , debugging :: Bool -- ^ @debugging@ Controls wether debugging is enabled. Which enables memory tracking+ , warnings :: Bool -- ^ @warnings@ Check if warnings should be printed+ , warnings_as_errors :: Bool -- ^ @warnings_as_errors@ Treat warnings as errors + , outputDIR :: String -- ^ @outputDir@ Redirect output to a folder+ , baseDir :: String -- ^ @baseDir@ Path to the base folder which contains the WinDll includes folder and template folder+ , tempDIR :: String -- ^ @tempDir@ Set the temporary folder to use+ , keep_temps :: Bool -- ^ @keep_temps@ Keep temporary files+ , outputFile :: String -- ^ @outputFile@ The output file name+ , platform :: Platform -- ^ @platform@ The platform to compile for+ , dllmain :: FilePath -- ^ @dllmain@ The path to the lib main file to use+ , dllmanual :: Bool -- ^ @dllmanual@ Indicates that you want to manually initialize the RTS. @dllmain@ will be ignored.+ , threaded :: Bool -- ^ @threaded@ Compile the lib using the threaded RTS. this implies dllmanual+ , options :: [Options] -- ^ @options@ The none executable flags+ , includes :: [FilePath] -- ^ @includes@ The list of extra source files to include with data definitions+ , workingset :: WorkingSet -- ^ @workingset@ The current working set for the project+ , pipeline :: Builder -- ^ @pipeline@ Contains cleanup information needed when program is exiting+ , include_foreigns :: Bool -- ^ @include_foreigns@ re-expose foreign declarations found when analyzing modules.+ , native_symbols :: [FilePath] -- ^ @native_symbols@ The list of Native Symbols to include in the generated .DEF files.+ }+ deriving Show+ +-- | Datatype that hold the information needed by the different components of the preprocessor+data WorkingSet = WorkingSet { dependencies :: [String] -- ^ @dependencies@ Module dependencies, Othe source files to traverse+ , modules :: [(Module, [CommentDecl])] -- ^ @modules@ A list of modules matched with their function comments, this is done before hand to save some time.+ , entrypoint :: String -- ^ @entrypoint@ The main entry point for the dll, will be generated based on the top dll given.+ , pragmas :: [Pragma] -- ^ @pramas@ Program wide control pragmas+ , n_exports :: [HaskellExport] -- ^ @n_exports@ the list of haskell exports found inside parsed modules. This gets populated when \include_foreigns\ is true.+ , n_hs2c :: [(String, String)] -- ^ @n_hs2c@ supplimentary list of conversions of Haskell to C, user provided+ , n_csize :: [(String, Int )] -- ^ @n_csize@ supplimentary list of C sizes, user provided+ , n_hs2cs :: Bool -> [(String, String)] -- ^ @n_hs2cs@ supplimentary list of conversions of Haskell to C#, user provided+ , n_hs2hs :: [(String, String)] -- ^ @n_hs2hs@ supplimentary list of conversions of Haskell to HSC, user provided+ }+ deriving Show+ +-- | DataType to hold all the filed we've build during the compilation phase in order to clean them up at the end+data Builder = Builder { files :: [FilePath] -- ^ @files@ The list of files compiled during the build phase.+ , dirPath :: FilePath -- ^ @dirPath@ The real directory to write in.+ , mergeDep :: Maybe ModInfo -- ^ @mergeDep@ Cached merged dependency tree. to prevent repeated recalculations+ , specs :: [(Name,Types)] -- ^ @specs@ Datatypes that need to be specialized.+ } deriving Show+ +-- | Contains the desugared processed module information+data ModInfo = ModInfo { modFunctions :: [Function] -- ^ @modFunctions@ Functions which are to be exported by FFI+ , modDatatypes :: (DataTypes, DataTypes) -- ^ @modDatatypes@ A tuple of (simple datatypes, dataypes to be specialized)+ , modExports :: [Export] -- ^ @modExports@ A list of exports generated from the functions+ , modCallbacks :: [Callback] -- ^ @modCallbacks@ The Haskell Callbacks generated from the exports and datatypes+ , modStablePtrs :: [Stable] -- ^ @modCallbacks@ The Haskell Callbacks generated from the exports and datatypes+ } deriving Show+ +-- | Monad transformer used to do all computations in +type Exec a = StateT Session (ErrorT String IO) a++-- | Make the Either a Monad instance +-- instance Monad (Either String) where+ -- fail str = Left str+ -- return a = Right a+ -- (Left str ) >>= _ = Left str+ -- (Right a) >>= f = f a+ +-- | And also make the Either a Functor+instance Functor (Either String) where+ fmap f (Left str) = Left str+ fmap f (Right a) = Right (f a)++-- | And a MonadPlus instance+instance MonadPlus (Either String) where+ mzero = Left ""+ (Left _) `mplus` xs = xs+ xs `mplus` ys = xs+ +-- | MonadIO instance so that liftIO can be used inside the StateT+-- instance MonadIO (Either String) where+ -- liftIO = (($!) return) . unsafePerformIO ++-- | The default session initialized to the values specific for windows+newSession = Session { mainFile = ""+ , absPath = ""+ , verbosity = 0+ , call = StdCall+ , namespace = exename+ , csharp = False+ , cpp = True+ , mvcpp = False+ , incDef = False+ , link_dynamic = False+ , pres_comment = True+ , include_foreigns = True+ , hackage_base_url = "http://hackage.haskell.org/packages/archive/"+ , hackage_list = "00-index.tar.gz"+ , hackage_src_url = "/latest/doc/html/src"+ , debugging = False+ , warnings = True+ , warnings_as_errors = False+ , outputDIR = "."+ , baseDir = []+ , tempDIR = unsafePerformIO getTemporaryDirectory+ , keep_temps = False+ , outputFile = []+ , platform = Windows+ , dllmain = []+ , dllmanual = True+ , threaded = False+ , options = []+ , includes = []+ , native_symbols = []+ , workingset = WorkingSet { dependencies = []+ , modules = [] + , entrypoint = []+ , pragmas = []+ , n_exports = []+ , n_hs2c = []+ , n_csize = []+ , n_hs2cs = const []+ , n_hs2hs = []+ }+ , pipeline = Builder { files = []+ , dirPath = []+ , mergeDep = Nothing+ , specs = []+ }+ }++-- | Guess the fullname of a target file+guessPath :: FilePath -> IO FilePath+guessPath mangled = + runGhc (Just libdir) $ + do target <- guessTarget mangled Nothing+ case targetId target of+ (TargetModule m) -> do let name = moduleNameSlashes m+ -- unsafePerformIO shouldn't be needed. There is an instance of MonadIO for GHC in + -- HscTypes, however, ghc for some reason can't find it. And it's bitching too much.+ exist = unsafePerformIO $ doesFileExist (name ++ ".hs") + case exist of+ True -> return $ name ++ ".hs"+ False -> return $ name ++ ".lhs"+ (TargetFile path _) -> return path
WinDll/Structs/C.hs view
@@ -22,7 +22,7 @@ import Data.Data import WinDll.Structs.Structures-import WinDll.Session (CallConvention)+import WinDll.Session.Hs2lib (CallConvention) -- | This structure hold include information of which files to include data Include = LibInclude Name -- ^ @LibInclude@ These are includes to be included from a standard location
WinDll/Structs/CSharp.hs view
@@ -21,7 +21,7 @@ import Data.Data -import WinDll.Session+import WinDll.Session.Hs2lib import WinDll.Structs.Structures import WinDll.Structs.Types
WinDll/Structs/Folds/C.hs view
@@ -16,7 +16,7 @@ import WinDll.Structs.C import WinDll.Structs.Types import WinDll.Structs.Structures(Callback)-import WinDll.Session(CallConvention)+import WinDll.Session.Hs2lib(CallConvention) -- * Type Algebras for the current ADTs in the C file
WinDll/Structs/Folds/CSharp.hs view
@@ -18,7 +18,7 @@ import WinDll.Structs.C import WinDll.Structs.Structures import WinDll.Structs.Types-import WinDll.Session+import WinDll.Session.Hs2lib -- import WinDll.Structs.Folds.C hiding (foldDataEnum)
WinDll/Structs/Folds/Haskell.hs view
@@ -22,7 +22,7 @@ -- | Type Algebra for the HaskellStorable ADT type HaskellStorableAlgebra a = ((Name -> [(Name,Int)] -> PtrName -> [TypeName] -> Bool -> [a] -> [a] -> Ann -> a)- ,(Name -> Int -> [StorablePoke] -> a)+ ,(Name -> ModuleName -> Int -> [StorablePoke] -> a) ,([StorablePeek] -> a) ) @@ -30,15 +30,15 @@ type StorablePeekAlgebra a = ((TypeName -> PtrName -> TypeName -> a) ,(Int -> [a] -> a) ,(Name -> TypeName -> Name -> PtrName -> TypeName -> a)- ,(Bool -> Name -> [(Name,TypeName,Ann)] -> a)+ ,(Bool -> Bool -> Name -> [(Name,TypeName,Ann)] -> ModuleName -> a) ) -- | Type Algebra for the StorablePoke ADT type StorablePokeAlgebra a = ((TypeName -> Field -> PtrName -> a -> a)- ,(Name -> TypeName -> a)+ ,(Bool -> Name -> TypeName -> a) ,(Name -> a)- ,(Bool -> Name -> Maybe Name -> Type -> Ann -> a)- , a+ ,(Bool -> Bool -> Name -> Maybe Name -> Type -> Ann -> a)+ ,ModuleName -> a ) -- * General folds for the algebras above@@ -47,22 +47,22 @@ foldHaskellStorable :: HaskellStorableAlgebra a -> HaskellStorable -> a foldHaskellStorable (hsstorable,hspoke,hspeek) = fold where fold (HSStorable a b c d e f g h) = hsstorable a b c d e (map fold f) (map fold g) h- fold (HSPoke a b c) = hspoke a b c+ fold (HSPoke a b c d) = hspoke a b c d fold (HSPeek a) = hspeek a -- | General fold for the StorablePeek ADT foldStorablePeek :: StorablePeekAlgebra a -> StorablePeek -> a foldStorablePeek (tag,entry,value,ret) = fold- where fold (PeekTag a b c) = tag a b c- fold (PeekEntry a b) = a `entry` (map fold b)- fold (PeekValue a b c d e) = value a b c d e- fold (PeekReturn a b c) = ret a b c+ where fold (PeekTag a b c) = tag a b c+ fold (PeekEntry a b) = a `entry` (map fold b)+ fold (PeekValue a b c d e) = value a b c d e+ fold (PeekReturn a b c d e) = ret a b c d e -- | General fold for the StorablePoke ADT foldStorablePoke :: StorablePokeAlgebra a -> StorablePoke -> a foldStorablePoke (tag,new,val,var,ret) = fold- where fold (PokeTag a b c d) = tag a b c (fold d)- fold (NewPtr a b) = a `new` b- fold (PokeValue a) = val a- fold (PokeVar a b c d e) = var a b c d e- fold (PokeReturn ) = ret+ where fold (PokeTag a b c d) = tag a b c (fold d)+ fold (NewPtr a b c) = new a b c+ fold (PokeValue a) = val a+ fold (PokeVar a b c d e f) = var a b c d e f+ fold (PokeReturn a) = ret a
WinDll/Structs/Haskell.hs view
@@ -26,8 +26,8 @@ import WinDll.Structs.Structures hiding (Import) import WinDll.Structs.C-import WinDll.Session-import qualified WinDll.Session as S+import WinDll.Session.Hs2lib+import qualified WinDll.Session.Hs2lib as S type Field = String type PtrName = String@@ -57,11 +57,11 @@ type Ptr_Type = TypeDecL -- | A Haskell function export-data HaskellFunction = HaskellFunction { hfnName :: Name -- ^ @hfnName@ Original function name- , hfnAs :: Name -- ^ @hfnAs@ re-exported function name/alias- , hfnType :: Type -- ^ @hfnType@ The working function type- , hfnAnn :: Ann -- ^ @hfnAnn@ Annotations associated with the @hfnType@- , hfnOrigType :: Type -- ^ @hfnOrigType@ The original (largely) unmodified type+data HaskellFunction = HaskellFunction { hfnName :: Name -- ^ @hfnName@ Original function name+ , hfnAs :: Name -- ^ @hfnAs@ re-exported function name/alias+ , hfnType :: Type -- ^ @hfnType@ The working function type+ , hfnAnn :: Ann -- ^ @hfnAnn@ Annotations associated with the @hfnType@+ , hfnOrigType :: Type -- ^ @hfnOrigType@ The original (largely) unmodified type } deriving(Eq,Show,Data,Typeable) @@ -69,16 +69,17 @@ type HaskellCallback = Callback -- | A datatype to hold all Storable instance definitions (Both normal and specializations)-data HaskellStorable = HSStorable { hsname :: Name -- ^ @hsname@ Name of the storable instance- , hsizes :: [(Name,Int)] -- ^ @hssizes@ A mapping from Constructors to arity to generate correct sizes- , hsptr :: PtrName -- ^ @hsptr@ The base pointer name to use in this instance- , hsvars :: [TypeName] -- ^ @hsvars@ The full type arity of the datatype- , hsspec :: Bool -- ^ @hsspec@ Whether the instance is a specialized instance or not. If it is FFIType should not be used and the types not escaped.- , pokes :: [HaskellStorable] -- ^ @pokes@ The pokes to be outputted by the program- , peeks :: [HaskellStorable] -- ^ @peeks@ The peeks to be generated by the program- , hsann :: Ann -- ^ @hsann@ The buffer containing the proper lookup annotations for translate+data HaskellStorable = HSStorable { hsname :: Name -- ^ @hsname@ Name of the storable instance+ , hsizes :: [(Name,Int)] -- ^ @hssizes@ A mapping from Constructors to arity to generate correct sizes+ , hsptr :: PtrName -- ^ @hsptr@ The base pointer name to use in this instance+ , hsvars :: [TypeName] -- ^ @hsvars@ The full type arity of the datatype+ , hsspec :: Bool -- ^ @hsspec@ Whether the instance is a specialized instance or not. If it is FFIType should not be used and the types not escaped.+ , pokes :: [HaskellStorable] -- ^ @pokes@ The pokes to be outputted by the program+ , peeks :: [HaskellStorable] -- ^ @peeks@ The peeks to be generated by the program+ , hsann :: Ann -- ^ @hsann@ The buffer containing the proper lookup annotations for translate } | HSPoke { pokename :: Name -- ^ @pokename@ The name of the Constructor we're generating instances for+ , pokeModule :: ModuleName -- ^ @pokeModule@ The name of the module exporting the constructor , pokearrity :: Int -- ^ @pokearrity@ The arrity of the current constructor , pokebody :: [StorablePoke] -- ^ @pokebody@ The body of the poke }@@ -90,15 +91,15 @@ data StorablePeek = PeekTag TypeName PtrName TypeName | PeekEntry Int [StorablePeek] | PeekValue Name TypeName Name PtrName TypeName- | PeekReturn Bool Name [(Name,TypeName,Ann)]+ | PeekReturn Bool Bool Name [(Name,TypeName,Ann)] ModuleName deriving(Eq,Show,Data,Typeable) -- | Structure to describe the Poke values in a Storable instance data StorablePoke = PokeTag TypeName Field PtrName StorablePoke- | NewPtr Name TypeName+ | NewPtr Bool Name TypeName | PokeValue Name- | PokeVar Bool Name (Maybe Name) Type Ann- | PokeReturn+ | PokeVar Bool Bool Name (Maybe Name) Type Ann+ | PokeReturn ModuleName deriving(Eq,Show,Data,Typeable) -- | Information about the Haskell file to generate
WinDll/Structs/MShow/C.hs view
@@ -19,7 +19,7 @@ import WinDll.Structs.Types import WinDll.Structs.Structures(Callback(..)) -import WinDll.Session(genCcall)+import WinDll.Session.Hs2lib(genCcall) import WinDll.CodeGen.Lookup import WinDll.Lib.NativeMapping
WinDll/Structs/MShow/CSharp.hs view
@@ -17,6 +17,7 @@ import WinDll.Structs.Folds.CSharp import WinDll.Structs.Folds.C import WinDll.Structs.CSharp+import qualified WinDll.Structs.CSharp as Cs import WinDll.Structs.C hiding (Normal) import WinDll.Structs.Structures @@ -34,9 +35,9 @@ instance MShow Attr where mshow = foldAttr (\p k v -> let pre = case p of- Normal -> ""- Param -> "param: "- Return -> "return: "+ Cs.Normal -> ""+ Cs.Param -> "param: "+ Cs.Return -> "return: " in pre ++ k ++ "(" ++ intercalate "," v ++ ")" ) instance MShow Argument where
WinDll/Structs/MShow/Haskell.hs view
@@ -21,9 +21,9 @@ import WinDll.Structs.Folds.C import WinDll.Structs.C import WinDll.Structs.MShow.Alignment-import WinDll.Parsers+import WinDll.Parsers.Hs2lib -import WinDll.Session(addParen)+import WinDll.Session.Hs2lib(addParen) import WinDll.Lib.NativeMapping @@ -58,12 +58,12 @@ mshow (TypeDecN name vars typ) = "type " ++ name ++ " " ++ unwords vars ++ "= " ++ mshowM 2 typ instance MShow HaskellExport where- mshow (HaskellExport cc ann (Export name ename typ _orig)) = + mshow (HaskellExport cc ann (Export name ename typ _orig modnm)) = let call = map toLower . show in "foreign export " ++ call cc ++ " \"" ++ ename ++ "\" " ++ name ++ " :: " ++ mshowM 3 (mkIO $ translatePartial (annWorkingSet ann) typ) instance MShow HaskellImport where- mshow (HaskellImport cc ann (Export name ename typ _orig)) = + mshow (HaskellImport cc ann (Export name ename typ _orig modnm)) = let call = map toLower . show in "foreign import " ++ call cc ++ " \"" ++ ename ++ "\" " ++ name ++ " :: " ++ mshowM 3 typ -- (translatePartial (annWorkingSet ann) typ) @@ -78,55 +78,83 @@ then init vars' else vars' size = last vars'- pokesz = "poke " ++ size ++ " (toFFI $! length res)"+ debug = annDebug ann+ pokesz = "poke " ++ size ++ " (toFFI " ++ st ++ "$! length res)" idx = annArrayIndices ann front = unwords [name, unwords vars',"="] indent = (replicate 5 ' ' ++) -- (replicate (length front) ' ' ++)- lines = munch mkFFI ((arity - 1) `delete` idx) vars+ lines = munch mkFFI debug ((arity - 1) `delete` idx) vars inner = ((maximum $ map (length.fst) lines)) `max` 3 binds = map (indent . (\(l,v) -> unwords [l ++ replicate (inner - length l - 1) ' ', "<-", v])) lines names = map fst lines res = if isIO typ then ["res" ++ replicate (inner - 3) ' ', "<-", orign] ++ names else ["let res =", orign] ++ names- ret = "toNative res"+ ret = "toNative " ++ st ++ "res"+ st = if debug then "st " else "" defs = map indent $ [unwords res] ++ if isList then [pokesz, ret] else [ret]- in unlines $ [line1,front] ++ addDo (binds ++ defs)+ dbgDef = if debug + then [indent $ "let st = newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(" ++ name ++ ")\")"]+ else []+ in unlines $ [line1,front] ++ addDo (dbgDef ++ binds ++ defs) where addDo :: [String] -> [String] addDo [] = [" do "] addDo (x:xs) = (" do " ++drop 5 x):xs type Key = String-type Munch = [Int] -> [String] -> Int -> ([(Key, String)], [String], Int -> Int) +type Munch = Bool -> [Int] -> [String] -> Int -> ([(Key, String)], [String], Int -> Int) mkFFI :: Munch-mkFFI _ [] _ = ([], [], id)-mkFFI idx l i = if i `elem` idx- then let (a:b:xs) = l - in ([(a++b, "fromList "++a++" "++b)], xs, (+2))- else let (a:xs) = l- in ([(a++"'", "fromNative "++a)], xs, (+1))- +mkFFI _ _ [] _ = ([], [], id)+mkFFI dbg idx l i = if i `elem` idx+ then let (a:b:xs) = l + st = mkBinds dbg "st" "fromList"+ in ([(a++b, mkDbgSym dbg st "fromList "++a++" "++b)], xs, (+2))+ else let (a:xs) = l+ st = mkBinds dbg "st" "fromNative"+ in ([(a++"p", mkDbgSym dbg st "fromNative "++a)], xs, (+1))+mkBinds dbg st name+ = if dbg + then "(pushStack " ++ st ++ " (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(" ++ name ++ ")\"))"+ else ""+ +mkCall dbg st name+ = let st' = mkBinds dbg st name+ in mkDbgSym dbg st' (name++" ")+ rmFFI :: Munch-rmFFI _ [] _ = ([], [], id)-rmFFI idx l i = if i `elem` idx- then let (a:xs) = l- in ([(a++"s'", "toNative $ length "++a)- ,(a++ "'","toNative "++a)], xs, (+1))+rmFFI _ _ [] _ = ([], [], id)+rmFFI dbg idx l i = if i `elem` idx+ then let (a:xs) = l + st1 = mkBinds dbg "st" "toNative" + st2 = mkBinds dbg "st" "toNative" + in ([(a++"sp", mkDbgSym dbg st1 "toNative " ++ "$ length "++a)+ ,(a++ "p", mkDbgSym dbg st2 "toNative " ++ a)], xs, (+1)) else let (a:xs) = l- in ([(a++"'", "toNative "++a)], xs, (+1))+ st = mkBinds dbg "st" "toNative"+ in ([(a++"p", mkDbgSym dbg st "toNative "++a)], xs, (+1))+ -munch :: Munch -> [Int] -> [String] -> [(Key, String)]-munch f idx list = munch' list 0+ +mkDbg :: Bool -> String -> String+mkDbg dbg = mkDbgSym dbg "st" + +mkDbgSym :: Bool -> String -> String -> String+mkDbgSym dbg sym = if dbg+ then (++sym++" ")+ else id+ +munch :: Munch -> Bool -> [Int] -> [String] -> [(Key, String)]+munch f dbg idx list = munch' list 0 where munch' :: [String] -> Int -> [(Key, String)] munch' [] _ = []- munch' x n = let (v, xs, g) = f idx x n+ munch' x n = let (v, xs, g) = f dbg idx x n in v ++ munch' xs (g n) instance MShow Stable where- mshow (Stable nm ty) = unlines [ nm ++ "A :: " ++ mshowM 2 (mk ty)- , nm ++ "A = freeStablePtr"- ]+ mshow (Stable nm ty monm) = unlines [ nm ++ "A :: " ++ mshowM 2 (mk ty)+ , nm ++ "A = freeStablePtr"+ ] where ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) mk ty = Exts.TyFun ty ctType @@ -143,22 +171,24 @@ then init vars' else vars' size = last vars'- pokesz = "poke " ++ size ++ " (toFFI $! length res)"- ret = "toNative res"- ret2 = if isList && not origIO then "fromNative (lld res)" else "fromNative res"+ debug = annDebug ann+ pokesz = "poke " ++ size ++ " (toFFI " ++ st ++ "$! length res)"+ ret = "toNative " ++ st ++ "res"+ ret2 = if isList && not origIO then mkDbg debug "fromNative " ++ "(lld res)" else mkDbg debug "fromNative " ++ "res" mkUsf b = if not b then (++" unsafePerformIO $") else id transtyIO = isIO transty origIO = isIO orig+ st = if debug then "st " else "" in unlines $ ["instance FFIType " ++ mshowM 2 (addParen orig) ++ " " ++ name ++ "Ptr where"- ," toNative x = mk" ++ name ++ " (toFFI x)"- ," fromFFI x = fromFFI (dyn" ++ name ++ " x)"- ," freeFFI x = freeHaskellFunPtr "+ ," toNative " ++ st ++ "x = mk" ++ name ++ " (toFFI " ++ st ++ "x)"+ ," fromFFI " ++ st ++ "x = fromFFI " ++ st ++ "(dyn" ++ name ++ " x)"+ ," freeFFI " ++ st ++ "x = freeHaskellFunPtr " ] ++ if null (annArrayIndices ann) then [] else ["" ,"instance FFIType " ++ mshowM 2 (addParen orig) ++ " " ++ mshowM 3 (addParen transty) ++ " where"- ,unlines $ (unwords $ " toFFI f" : vars' ++ [mkUsf transtyIO "="]) : mkResult mkFFI vars ret pokesz isList transtyIO idx' True- ,unlines $ (unwords $ " fromFFI f" : vars2 ++ [mkUsf origIO "="]) : mkResult rmFFI vars2 ret2 pokesz False origIO idx' (not isList)+ ,unlines $ (unwords $ (" toFFI " ++ st ++ "f") : vars' ++ [mkUsf transtyIO "="]) : mkResult mkFFI vars ret pokesz isList transtyIO idx' True+ ,unlines $ (unwords $ (" fromFFI " ++ st ++ "f") : vars2 ++ [mkUsf origIO "="]) : mkResult rmFFI vars2 ret2 pokesz False origIO idx' (not isList) ] where addDo :: [String] -> [String] addDo [] = [" do "]@@ -166,9 +196,9 @@ mkResult mnch vrs rt pk lst io dlst sat = let indent = (replicate 8 ' ' ++)- lines = munch mnch dlst vrs+ lines = munch mnch (annDebug ann) dlst vrs inner = ((maximum $ map (length.fst) lines)) `max` 3- binds = map (indent . (\(l,v) -> unwords [l ++ replicate (inner - length l - 1) ' ', "<-", v])) lines+ binds = map (indent . (\(l,v) -> unwords [l ++ replicate (inner - length l - 1) ' ', "<-" , v])) lines names = map fst lines res = if io && sat then ["res" ++ replicate (inner - 3) ' ', "<- f"] ++ names@@ -191,7 +221,7 @@ | otherwise = '_' : toLower x : toHSC xs instance MShow HaskellStorable where mshow _ = error "HaskellStorable: mshow - please call mshowWithPath"- mshowWithPath path nspace opath = foldHaskellStorable (hsstorable,hspoke,hspeek)+ mshowWithPath dbg path nspace opath = foldHaskellStorable (hsstorable,hspoke,hspeek) where hsstorable _name _size _ptr _vars _spec _pok _pek _ann = unlines' $ @@ -202,7 +232,11 @@ -- ,"{-# INLINE poke #-}" ,inline (unlines' (map (unlines.adj.lines) _pok)) -- ,"{-# INLINE peek #-}"- ,"peek " ++ _ptr ++ " = do "+ ,"peek " ++ _ptr ++ " = do " + ++ if dbg+ then "\n" ++ (indent $ indent $ "let st = newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(Storable " + ++ val_head ++ "@peek)\")")+ else "" ,unlines _pek ]) where inst_head = case (length _vars') `compare` 1 of@@ -220,10 +254,13 @@ adj [] = [] adj (x:xs) = (indent $ "poke " ++ _ptr ++ " "++x):(map indent xs) mkHead x = "(" ++ foldr1 (\a b->a++", "++b) x ++ ")"- hspoke _n _i x = let f = map (unlines'.map indent.lines.mshow)+ hspoke _n modnm _i x = let f = map (unlines'.map indent.lines.mshow) dat = unwords ["a"++show x|x<-[1.._i]]- var = (if _i == 0 then _n else "("++_n++" "++dat++")") ++" = do"- in (unlines . (var:) . f) $ if null x then [PokeReturn] else x+ var = let x = (if _i == 0 then _n else "("++_n++" "++dat++")") ++" = do"+ x' = indent $ "let st = newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(Storable " + ++ _n ++ "@poke)\")"+ in if dbg then ((x:) . (x':)) else (x:)+ in (unlines . var . f) $ if null x then [PokeReturn modnm] else x hspeek x = inline $ unlines' $ map (unlines'.(map (indent.indent)).lines.mshow) x instance MShow StorablePeek where@@ -240,11 +277,14 @@ value _var _type _name _ptr _typevar = _var ++ " <- (#peek " ++ _type ++ "_t, " ++ _name ++ ") " ++ _ptr ++ " :: IO " ++ _typevar- ret _b _type tlist = let mk = if _b then "fromNative" else "return"+ ret dbg _b _type + tlist modnm = let mk = if _b + then mkCall dbg "st" "fromNative" + else "return " vars = map (('x':).show) [1..(length tlist)] args = [ case annArrayIsList ann of - False -> mk++" " ++x++ "' :: IO " ++ paren y- True -> "fromList " ++ x ++"s " ++ x ++ "'" | (y,x,ann)<-tlist]+ False -> mk++x++ "' :: IO " ++ paren y+ True -> mkCall dbg "st" "fromList" ++ x ++"s " ++ x ++ "'" | (y,x,ann)<-tlist] lines = zip vars args paren = \v -> if ' ' `elem` v then "(" ++ v ++ ")" else v inner = ((maximum $ map (length.fst) lines)) `max` 3@@ -259,21 +299,25 @@ in case lines (mshow _poke) of [_name, _rest] -> unlines' [ _rest, mk _name ] _rest -> mk $ unlines' _rest- new _name _type = _name ++ " <- malloc :: IO (Ptr " ++ _type ++ ")"+ new dbg _name _type = if dbg + then _name ++ " <- malloc (newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"()\")) :: IO (Ptr " ++ _type ++ ")"+ else _name ++ " <- malloc :: IO (Ptr " ++ _type ++ ")" val _val = _val- var _b _name _ren - _type _ann = let mk = if _b then "toNative" else "return"+ var dbg _b _name + _ren _type _ann = let mk = if _b + then mkCall dbg "st" "toNative" + else "return " tr = if _b then translatePartial (annWorkingSet _ann) else id _newname = _name ++ "x" _value = maybe _name id _ren in unlines' [_newname- ,_newname ++ " <- " ++ mk ++ " " ++ _value ++" :: IO " ++ (mshowM 4 $ tr _type)+ ,_newname ++ " <- " ++ mk ++ _value ++" :: IO " ++ (mshowM 4 $ tr _type) ]- ret = "return ()"+ ret modnm = "return ()" instance MShow HaskellFile where mshow _ = error "HaskellFile: mshow - please call mshowWithPath"- mshowWithPath a b c hsfile =+ mshowWithPath dbg a b c hsfile = unlines $ [init $ mshowList (comments hsfile) ,mshowList (pragmas hsfile)@@ -289,7 +333,7 @@ ,init $ mshowList (hsfuncs hsfile) ,mshowList (hscallbacks hsfile) ,mshowList (hsstables hsfile)- ,mshowListWithPath a b c (hsstorable hsfile)+ ,mshowListWithPath dbg a b c (hsstorable hsfile) ] -- | Variant of unlines that does not add a newline char after everyline, only inbetween
WinDll/Structs/MShow/MShow.hs view
@@ -24,11 +24,11 @@ mshowM :: Int -> a -> String mshowM _ = mshow - mshowWithPath :: String -> String -> String -> a -> String- mshowWithPath _ _ _ = mshow+ mshowWithPath :: Bool -> String -> String -> String -> a -> String+ mshowWithPath _ _ _ _ = mshow - mshowListWithPath :: String -> String -> String -> [a] -> String- mshowListWithPath a b c = unlines.map (mshowWithPath a b c)+ mshowListWithPath :: Bool -> String -> String -> String -> [a] -> String+ mshowListWithPath a b c d = unlines.map (mshowWithPath a b c d) instance MShow String where mshow = id
WinDll/Structs/PrettyPrinting.hs view
@@ -18,18 +18,19 @@ import WinDll.Structs.MShow.HaskellSrcExts import WinDll.Structs.MShow.MShow import WinDll.Lib.NativeMapping-import WinDll.Version ( verStr )+import WinDll.Version.Hs2lib ( verStr ) import Data.Foldable (foldl') import Data.List(isPrefixOf,sort) instance Show Export where- showsPrec d (Export name exported types _) = - showString "foreign export stdcall " .- showString (show exported) .- showString " " .- showString name .- showString " :: " .+ showsPrec d (Export name exported types _ mod) = + showString "foreign export stdcall " .+ showString (show exported) .+ showString " " .+ showString name .+ if null mod then id else (++ "." ++ mod) .+ showString " :: " . showString (mshow types) @@ -66,7 +67,7 @@ printData True d name types [body] showsPrec d (DataType name types body tag) = printData False d name types body- showsPrec d (Constr name types) = + showsPrec d (Constr name datafix types) = showString name . showString " " . showString (mshow types)@@ -131,7 +132,7 @@ -- | Generate the export list from the given module. generateExportList :: Module -> String generateExportList (Module _ _ _ export _ _ _ _) = showString "EXPORTS\n" (unlines list)- where gmap f [] = []- gmap f ((Export n _ _ _):xs) = f n:gmap f xs+ where gmap f [] = []+ gmap f ((Export n _ _ _ _):xs) = f n:gmap f xs nums = [1..(length export)] list = (zipWith ($) (gmap (\a b->"\t"++a++"\t@"++show b) export) nums)
WinDll/Structs/Structures.hs view
@@ -72,6 +72,7 @@ , exAs :: ExportName -- ^ The name to export the function under , exType :: Type -- ^ The modified type. (preprocessed to support lists etc) , exOrgType :: Type -- ^ The original unmodified type + , exModule :: ModuleName -- ^ The definition site for the export } deriving(Eq,Data,Typeable) @@ -87,10 +88,14 @@ -- like the full type name. This is needed because the declarations will be -- processed independently of their module declarations. So this information is needed data DataType = DataType Name [TypeName] DataTypes TypeTag - | NewType Name [TypeName] DataType TypeTag - | Constr Name AnnNamedTypes + | NewType Name [TypeName] DataType TypeTag + | Constr Name DataFixity AnnNamedTypes deriving(Eq,Data,Typeable) +-- | The fixity of the constructor +data DataFixity = Infix | Normal + deriving(Eq,Data,Typeable) + -- | Determine if a datatype is a Simple type (e.g. ahs no type variables) or a datatype that needs to be specialized isSimpleData :: DataType -> Bool isSimpleData (DataType _ a _ _) = null a @@ -131,7 +136,7 @@ getTypes :: DataType -> [Type] getTypes (NewType _ _ t _) = getTypes t getTypes (DataType _ _ t _) = concatMap getTypes t -getTypes (Constr _ t) = filter hasVars $ map antType t +getTypes (Constr _ _ t) = filter hasVars $ map antType t -- | Checks to see if this type is a TyVar isVar :: Type -> Bool @@ -163,8 +168,9 @@ deriving(Eq,Show,Data,Typeable) -- | Represents a StablePtr implementation that needs to be freed. -data Stable = Stable { stName :: Name -- ^ The user displayed name for the StablePtr - , stType :: Type -- ^ The actual type of the StablePtr +data Stable = Stable { stName :: Name -- ^ The user displayed name for the StablePtr + , stType :: Type -- ^ The actual type of the StablePtr + , stModule :: ModuleName -- ^ The module that defined the StablePtr } deriving(Eq,Show,Data,Typeable)
WinDll/Structs/Types.hs view
@@ -23,6 +23,7 @@ import Data.Monoid type Name = String+type ModuleName = String type Import = String type ExportName = String type Type = Exts.Type@@ -34,8 +35,11 @@ instance Monoid Ann where mempty = noAnn- mappend (Ann a1 b1 c1 d1 e1 f1 g1) - (Ann a2 b2 c2 d2 e2 f2 g2) = Ann (nub $ a1 ++ a2) (b1 || b2) (nub $ c1 ++ c2) (nub $ d1 ++ d2) (nub $ e1 ++ e2) (nub $ f1 ++ f2) (\v -> nub $ g1 v ++ g2 v)+ mappend (Ann a1 b1 c1 d1 e1 f1 g1 h1 i1) + (Ann a2 b2 c2 d2 e2 f2 g2 h2 i2) = Ann (nub $ a1 ++ a2) (b1 || b2) + (nub $ c1 ++ c2) (nub $ d1 ++ d2) (nub $ e1 ++ e2)+ (nub $ f1 ++ f2) (\v -> nub $ g1 v ++ g2 v) (h1 || h2)+ (i1 ++ " " ++ i2) -- | Annotation on functions, This allows more complex types to be expressed data Ann = Ann { annArrayIndices :: [Int] -- ^ Offsets into the type list to indicate which fields are counters for lists@@ -45,6 +49,8 @@ , annWorkingSetC :: [(String, String)] -- ^ Copy of the definition list for the C translation functions , annWorkingSetCSize :: [(String, Int)] -- ^ Copy of the definition list for the C sizes translation functions , annWorkingSetCs :: Bool -> [(String, String)] -- ^ Copy of the definition list for the C# translation functions+ , annDebug :: Bool -- ^ Indicates is debugging has been enabled for this session+ , annModule :: ModuleName } deriving(Show,Eq,Data,Typeable) @@ -55,10 +61,11 @@ show f = unlines [show (f True), show (f False)] -- | Annotated type, basically a 4-tuple that holds all possible information on a datatype field-data AnnType = AnnType { antName :: Name -- ^ The field name, if this is a record the name will be the record name.- , antType :: Type -- ^ The preprocessed type of the field- , antAnn :: Ann -- ^ The type annotations for the antType- , antOrigType :: Type -- ^ The original unpreprocessed type+data AnnType = AnnType { antName :: Name -- ^ The field name, if this is a record the name will be the record name.+ , antType :: Type -- ^ The preprocessed type of the field+ , antAnn :: Ann -- ^ The type annotations for the antType+ , antOrigType :: Type -- ^ The original unpreprocessed type+ , antModule :: ModuleName -- ^ The module that originally defined the type } deriving(Show,Eq,Data,Typeable) @@ -71,6 +78,8 @@ , annWorkingSetC = [] , annWorkingSetCSize = [] , annWorkingSetCs = const []+ , annDebug = False+ , annModule = [] } -- | Find any Names embedded within any arbitraty structures
WinDll/Utils/DepScanner.hs view
@@ -15,7 +15,7 @@ module WinDll.Utils.DepScanner where -import WinDll.Session+import WinDll.Session.Hs2lib import WinDll.Utils.Feedback import GHC
WinDll/Utils/Feedback.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Windll @@ -14,7 +15,11 @@ module WinDll.Utils.Feedback where -import WinDll.Session +#ifdef DEBUG +import WinDll.Session.Debug +#else +import WinDll.Session.Hs2lib +#endif import Control.Monad.State @@ -22,6 +27,9 @@ import System.Exit import System.Directory +import Data.Function +import Text.Printf + -- | debug function that prints out de given message only if the specified debug level -- is atleast that which was specified by the commandline options to the program -- @@ -34,20 +42,46 @@ do session <- get let dbg = verbosity session liftIO $ when (level <= dbg && dbg /= 0) $ putStrLn ("*** " ++ msg) - return () +-- | Print out a progress bar. This prints and updates a progressbar in ASCII format. +-- The arguments are as follows: +-- debug level - When to print the progress +-- current - The current count of the progress +-- total - The total number of items being processed +-- width - Total amount of stars to render +progress :: Int -> Int -> Int -> Int -> Exec () +progress level current total width + = do session <- get + let perc = ((/) `on` fromIntegral) current total :: Float + stars = round $ perc * (fromIntegral width) + bars = width - stars + dbg = verbosity session + liftIO $ when (level <= dbg) $ putStr $ "\r*** Analyzing [" ++ replicate stars '*' ++ replicate bars '-' ++ "] " ++ printf "%.2f" (perc * 100) ++ "%" + -- | Normal Information message _normal = 1 :: Int -- | Detauled Information message _detail = 2 :: Int +-- | Always print this message +_always = 0 :: Int + +-- | Always print +echo :: String -> Exec () +echo = liftIO . putStrLn . ("*** "++) + -- | Give the user a warning and exits if warnings are treated like errors warn :: String -> Exec () warn msg = do session <- get +#ifdef DEBUG + let werr = False + let warnings_enabled = True +#else let werr = warnings_as_errors session let warnings_enabled = warnings session +#endif liftIO $ when (warnings_enabled && not werr) $ putStrLn ("Warning: " ++ msg) if werr then die msg else return () @@ -61,6 +95,7 @@ cleanup = do inform _normal "Cleaning up...." session <- get +#ifndef DEBUG let build = pipeline session dir = dirPath build case keep_temps session || null (files build) of @@ -69,5 +104,5 @@ False -> mapM_ (\a->inform _detail ("Cleaning '" ++ a ++ "'...") >> liftIO (removeFile (dir++a))) (files build) >> inform _detail ("Removing " ++ dir ++ "...") >> liftIO (removeDirectoryRecursive dir) - +#endif inform _detail "Cleanup done..."
WinDll/Utils/HaddockRead.hs view
@@ -22,7 +22,7 @@ import System.FilePath import WinDll.Utils.Processes-import WinDll.Session+import WinDll.Session.Hs2lib import WinDll.Utils.Feedback import System.FilePath @@ -85,7 +85,10 @@ do session <- get let dir = addTrailingPathSeparator (baseDir session) deps = (dependencies.workingset) session- paths = (absPath session : map guessPath (drop 1 deps))+ + mpaths <- liftIO $ mapM guessPath (drop 1 deps)+ + let paths = (absPath session : mpaths) return ("main.txt" , -- ["--optghc=\"-i" ++ if ' ' `elem` dir then show dir else dir ++ "\"" ("--hoogle" : map (dir++) paths)
WinDll/Utils/Pragma.hs view
@@ -16,7 +16,7 @@ module WinDll.Utils.Pragma where -import WinDll.Session +import WinDll.Session.Hs2lib import WinDll.Utils.Feedback import WinDll.Structs.Structures import WinDll.Lib.Native
WinDll/Utils/Processes.hs view
@@ -16,7 +16,7 @@ module WinDll.Utils.Processes where import WinDll.Builder-import WinDll.Session+import WinDll.Session.Hs2lib import WinDll.Utils.Feedback import WinDll.EntryPoint @@ -160,6 +160,7 @@ ++ ["-fno-warn-deprecated-flags" ,"-O2" ,"-package ghc"+ ,"-package Hs2lib" ,"-i" ++ if ' ' `elem` dir then show dir else dir --,"-outputdir " ++ if ' ' `elem` odir then show odir else odir ,"-optl --enable-stdcall-fixup"
− WinDll/Version.hs
@@ -1,44 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : Windll --- Copyright : (c) Tamar Christina 2009 - 2010 --- License : BSD3 --- --- Maintainer : tamar@zhox.com --- Stability : experimental --- Portability : portable --- --- This module contains versioning information about the tool. --- ------------------------------------------------------------------------------ - -module WinDll.Version where - -import Data.List ( intercalate ) -import Data.Char ( toUpper ) - --- | Version Number -verNum :: [Int] -verNum = [0,4,8] - --- | Version string -verStr :: String -verStr = (intercalate "." . map show) verNum - --- | Product version -version :: String -version = verStr ++ " ~Experimental~" - --- | Version message including product name -versionmsg :: String -versionmsg = exename - ++ " Build version " ++ version - ++ "\n(c) Tamar Christina <tamar@zhox.com>. 2009 - 2011." - --- | Product name -exename :: String -exename = "Hs2lib" - --- | Product name converted to uppercase -upper_name :: String -upper_name = map toUpper exename
+ WinDll/Version/Debug.hs view
@@ -0,0 +1,44 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- This module contains versioning information about the debug tool. +-- +----------------------------------------------------------------------------- + +module WinDll.Version.Debug where + +import Data.List ( intercalate ) +import Data.Char ( toUpper ) + +-- | Version Number +verNum :: [Int] +verNum = [0,0,1] + +-- | Version string +verStr :: String +verStr = (intercalate "." . map show) verNum + +-- | Product version +version :: String +version = verStr ++ " ~Experimental~" + +-- | Version message including product name +versionmsg :: String +versionmsg = exename + ++ " Build version " ++ version + ++ "\n(c) Tamar Christina <tamar@zhox.com>. 2009 - 2011." + +-- | Product name +exename :: String +exename = "Hs2lib-debug" + +-- | Product name converted to uppercase +upper_name :: String +upper_name = map toUpper exename
+ WinDll/Version/Hs2lib.hs view
@@ -0,0 +1,44 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- This module contains versioning information about the main tool. +-- +----------------------------------------------------------------------------- + +module WinDll.Version.Hs2lib where + +import Data.List ( intercalate ) +import Data.Char ( toUpper ) + +-- | Version Number +verNum :: [Int] +verNum = [0,5,0] + +-- | Version string +verStr :: String +verStr = (intercalate "." . map show) verNum + +-- | Product version +version :: String +version = verStr ++ " ~Experimental~" + +-- | Version message including product name +versionmsg :: String +versionmsg = exename + ++ " Build version " ++ version + ++ "\n(c) Tamar Christina <tamar@zhox.com>. 2009 - 2011." + +-- | Product name +exename :: String +exename = "Hs2lib" + +-- | Product name converted to uppercase +upper_name :: String +upper_name = map toUpper exename