Hs2lib (empty) → 0.4.8
raw patch · 84 files changed
+9332/−0 lines, 84 filesdep +QuickCheckdep +arraydep +basesetup-changedbinary-added
Dependencies added: QuickCheck, array, base, cereal, containers, directory, filepath, ghc, ghc-paths, haddock, haskell-src-exts, mtl, old-locale, process, random, syb, time
Files
- Hs2lib.cabal +122/−0
- Hs2lib.hs +77/−0
- Includes/FFI.dll binary
- Includes/FFI/FFI.csproj +67/−0
- Includes/FFI/FFI.sln +20/−0
- Includes/FFI/FFI.suo binary
- Includes/FFI/LockedValue.cs +67/−0
- Includes/FFI/Properties/AssemblyInfo.cs +36/−0
- Includes/FFI/SafeString.cs +63/−0
- Includes/FFI/WinLib.cs +187/−0
- Includes/Instances.h +35/−0
- Includes/Tuples.h +67/−0
- Includes/WinDllSupport.dll binary
- Includes/WinDllSupport.exp binary
- Includes/WinDllSupport.h +28/−0
- Includes/WinDllSupport.lib binary
- LICENSE.txt +20/−0
- LIMITS.TXT +25/−0
- ListTest.hs +39/−0
- Setup.lhs +6/−0
- Templates/main.template-unix.c +26/−0
- Templates/main.template-win.c +23/−0
- Templates/nomain.template-unix.c +21/−0
- Templates/nomain.template-win.c +22/−0
- Tests/FindFiles.hs +40/−0
- Tests/Src/Test_ADT.hs +38/−0
- Tests/Src/Test_AdvanceCall.hs +11/−0
- Tests/Src/Test_AdvancedListCall.hs +19/−0
- Tests/Src/Test_AdvancedListCallbacks.hs +21/−0
- Tests/Src/Test_AdvancedListTests.hs +28/−0
- Tests/Src/Test_Bewijzen.hs +162/−0
- Tests/Src/Test_Getallen.hs +153/−0
- Tests/Src/Test_IO.hs +22/−0
- Tests/Src/Test_SimpleCall.hs +5/−0
- Tests/Src/Test_SimpleLists.hs +9/−0
- Tests/Src/Test_SimpleTuple.hs +33/−0
- Tests/Src/Test_SimpleType.hs +39/−0
- Tests/Src/Test_StateDemo.hs +41/−0
- Tests/Src/Test_Validation.hs +170/−0
- Tests/Src/data.txt +19/−0
- Tests/TestRunner.hs +62/−0
- WinDll/Builder.hs +92/−0
- WinDll/COFF/Lib.hs +405/−0
- WinDll/CmdArgs.hs +176/−0
- WinDll/CodeGen/C.hs +211/−0
- WinDll/CodeGen/CSharp/CSharp.hs +209/−0
- WinDll/CodeGen/Haskell.hs +297/−0
- WinDll/CodeGen/Lookup.hs +146/−0
- WinDll/EntryPoint.hs +98/−0
- WinDll/Identifier.hs +404/−0
- WinDll/Lib/Converter.hs +15/−0
- WinDll/Lib/Instances.hs +117/−0
- WinDll/Lib/InstancesTypes.hs +30/−0
- WinDll/Lib/Native.hs +140/−0
- WinDll/Lib/NativeMapping.hs +384/−0
- WinDll/Lib/Tuples.hs +637/−0
- WinDll/Lib/Tuples.hsc +464/−0
- WinDll/Parsers.hs +566/−0
- WinDll/Session.hs +248/−0
- WinDll/Shared/Remapper.hs +95/−0
- WinDll/Structs/C.hs +80/−0
- WinDll/Structs/CSharp.hs +110/−0
- WinDll/Structs/Folds/C.hs +100/−0
- WinDll/Structs/Folds/CSharp.hs +69/−0
- WinDll/Structs/Folds/Haskell.hs +68/−0
- WinDll/Structs/Folds/HaskellSrcExts.hs +78/−0
- WinDll/Structs/Haskell.hs +122/−0
- WinDll/Structs/MShow/Alignment.hs +84/−0
- WinDll/Structs/MShow/C.hs +95/−0
- WinDll/Structs/MShow/CSharp.hs +123/−0
- WinDll/Structs/MShow/Haskell.hs +304/−0
- WinDll/Structs/MShow/HaskellSrcExts.hs +147/−0
- WinDll/Structs/MShow/MShow.hs +54/−0
- WinDll/Structs/PrettyPrinting.hs +137/−0
- WinDll/Structs/Structures.hs +259/−0
- WinDll/Structs/Types.hs +80/−0
- WinDll/Utils/DepScanner.hs +68/−0
- WinDll/Utils/Feedback.hs +73/−0
- WinDll/Utils/HaddockRead.hs +92/−0
- WinDll/Utils/Pragma.hs +76/−0
- WinDll/Utils/Processes.hs +217/−0
- WinDll/Utils/TypeFolds.hs +227/−0
- WinDll/Utils/Types.hs +68/−0
- WinDll/Version.hs +44/−0
+ Hs2lib.cabal view
@@ -0,0 +1,122 @@+Name: Hs2lib +Version: 0.4.8 +Cabal-Version: >= 1.10 +Build-Type: Simple +License: BSD3 +License-File: LICENSE.txt +Author: Tamar Christina <tamar@zhox.com> +Maintainer: Tamar Christina <tamar@zhox.com> +Homepage: http://blog.zhox.com/category/hs2lib/ +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. + . + 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. + . + It will always generated the required C types for use when calling the dll, but it will also generate the C# unsafe code if requested. + . + Read http://blog.zhox.com/hs2lib.pdf (not published yet) + . + Current Restrictions: + . + - You cannot export functions which have the same name (even if they're in different modules because 1 big hsc file is generated at the moment, no conflict resolutions) + . + - You cannot export datatypes with the same name, same restriction as above. + . + - Does not support automatic instance generation for infix constructors yet + . +Data-Files: Templates/main.template-unix.c, + Templates/main.template-win.c, + Templates/nomain.template-unix.c, + Templates/nomain.template-win.c, + Includes/Tuples.h, + Includes/Instances.h, + Includes/FFI.dll + Includes/FFI/Properties/AssemblyInfo.cs + Includes/FFI/FFI.sln + Includes/FFI/FFI.csproj + Includes/FFI/LockedValue.cs + Includes/FFI/SafeString.cs + Includes/FFI/FFI.suo + Includes/FFI/WinLib.cs + Includes/WinDllSupport.dll + Includes/WinDllSupport.lib + Includes/WinDllSupport.exp + Includes/WinDllSupport.h + + +Tested-With: GHC >= 6.12 +Build-Depends: base >= 4, + syb >= 0.1.0.2 +Extra-Source-Files: WinDll/*.hs, + WinDll/CodeGen/*.hs, + WinDll/CodeGen/CSharp/*.hs, + WinDll/COFF/*.hs, + WinDll/Lib/*.hsc, + WinDll/Lib/*.hs, + WinDll/Shared/*.hs, + WinDll/Structs/*.hs, + WinDll/Structs/Folds/*.hs, + WinDll/Structs/MShow/*.hs, + WinDll/Utils/*.hs, + Tests/*.hs, + Tests/Src/*.hs, + Tests/Src/*.txt, + *.hs, + Includes/*.h, + Includes/*.dll, + Includes/*.exp, + Includes/*.lib, + LIMITS.TXT + +Library + Exposed: True + Exposed-Modules: WinDll.Lib.Converter, + WinDll.Lib.NativeMapping, + WinDll.Lib.Native, + WinDll.Lib.Tuples, + WinDll.Structs.Types, + WinDll.Lib.InstancesTypes + + 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 + + Other-Modules: Paths_Hs2lib + Default-Language: Haskell98 + + if !os(windows) + GHC-Options: -fPIC + + Build-Tools: hsc2hs + Include-Dirs: Includes + + +Executable Hs2lib + Main-is: Hs2lib.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 + + Other-Modules: Paths_Hs2lib + Default-Language: Haskell98
+ Hs2lib.hs view
@@ -0,0 +1,77 @@+----------------------------------------------------------------------------- +-- | +-- 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 +import WinDll.Session +import WinDll.Utils.Feedback +import WinDll.Utils.DepScanner hiding (main) +import WinDll.Parsers +import WinDll.EntryPoint +import WinDll.Identifier +import WinDll.Builder +import WinDll.CodeGen.C +import WinDll.CodeGen.CSharp.CSharp +import WinDll.CodeGen.Haskell +import WinDll.Utils.Processes + +import System.Info +import Control.Monad.State +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..." + session <- get + + -- These lines do all the needed calculations + + traceDeps -- Read all dependencies, so we find the tree of files which need parsing + readFromFiles -- Read all datastructures from the read dependencies. + enablePragmas -- Process the enabled commandline pragmas. The other pragmas are determined later on + generateEntryPoint -- Generate the C entry points. + + -- The following lines do actual writing of outputs + + runComponent ( writeCFiles >> writeHaskellFiles >> writeEntryPoint ) + + when (csharp session) writeCsFiles + + -- compile everything up + + runCompilePipeLine + + -- clean up + cleanup + + inform _detail "Program terminating..." + liftIO $ putStrLn "Done."
+ Includes/FFI.dll view
binary file changed (absent → 7680 bytes)
+ Includes/FFI/FFI.csproj view
@@ -0,0 +1,67 @@+<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <Configuration Condition=" '$(Configuration)' == '' ">Debug</Configuration> + <Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform> + <ProductVersion>8.0.30703</ProductVersion> + <SchemaVersion>2.0</SchemaVersion> + <ProjectGuid>{6CDB8398-6FDC-4E2C-85A6-389C688610A5}</ProjectGuid> + <OutputType>Library</OutputType> + <AppDesignerFolder>Properties</AppDesignerFolder> + <RootNamespace>FFI</RootNamespace> + <AssemblyName>FFI</AssemblyName> + <TargetFrameworkVersion>v4.0</TargetFrameworkVersion> + <FileAlignment>512</FileAlignment> + </PropertyGroup> + <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' "> + <DebugSymbols>true</DebugSymbols> + <DebugType>full</DebugType> + <Optimize>false</Optimize> + <OutputPath>bin\Debug\</OutputPath> + <DefineConstants>DEBUG;TRACE</DefineConstants> + <ErrorReport>prompt</ErrorReport> + <WarningLevel>4</WarningLevel> + <AllowUnsafeBlocks>true</AllowUnsafeBlocks> + </PropertyGroup> + <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' "> + <DebugType>pdbonly</DebugType> + <Optimize>true</Optimize> + <OutputPath>bin\Release\</OutputPath> + <DefineConstants>TRACE</DefineConstants> + <ErrorReport>prompt</ErrorReport> + <WarningLevel>4</WarningLevel> + <AllowUnsafeBlocks>true</AllowUnsafeBlocks> + </PropertyGroup> + <PropertyGroup> + <SignAssembly>false</SignAssembly> + </PropertyGroup> + <PropertyGroup> + <AssemblyOriginatorKeyFile>Key.snk</AssemblyOriginatorKeyFile> + </PropertyGroup> + <ItemGroup> + <Reference Include="System" /> + <Reference Include="System.Core" /> + <Reference Include="System.Xml.Linq" /> + <Reference Include="System.Data.DataSetExtensions" /> + <Reference Include="Microsoft.CSharp" /> + <Reference Include="System.Data" /> + <Reference Include="System.Xml" /> + </ItemGroup> + <ItemGroup> + <Compile Include="LockedValue.cs" /> + <Compile Include="Properties\AssemblyInfo.cs" /> + <Compile Include="SafeString.cs" /> + <Compile Include="WinLib.cs" /> + </ItemGroup> + <ItemGroup> + <None Include="Key.snk" /> + </ItemGroup> + <Import Project="$(MSBuildToolsPath)\Microsoft.CSharp.targets" /> + <!-- To modify your build process, add your task inside one of the targets below and uncomment it. + Other similar extension points exist, see Microsoft.Common.targets. + <Target Name="BeforeBuild"> + </Target> + <Target Name="AfterBuild"> + </Target> + --> +</Project>
+ Includes/FFI/FFI.sln view
@@ -0,0 +1,20 @@+ +Microsoft Visual Studio Solution File, Format Version 11.00 +# Visual Studio 2010 +Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "FFI", "FFI.csproj", "{6CDB8398-6FDC-4E2C-85A6-389C688610A5}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Any CPU = Debug|Any CPU + Release|Any CPU = Release|Any CPU + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {6CDB8398-6FDC-4E2C-85A6-389C688610A5}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {6CDB8398-6FDC-4E2C-85A6-389C688610A5}.Debug|Any CPU.Build.0 = Debug|Any CPU + {6CDB8398-6FDC-4E2C-85A6-389C688610A5}.Release|Any CPU.ActiveCfg = Release|Any CPU + {6CDB8398-6FDC-4E2C-85A6-389C688610A5}.Release|Any CPU.Build.0 = Release|Any CPU + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal
+ Includes/FFI/FFI.suo view
binary file changed (absent → 16896 bytes)
+ Includes/FFI/LockedValue.cs view
@@ -0,0 +1,67 @@+using System; +using System.Collections.Generic; +using System.Linq; +using System.Text; +using System.Threading; + +namespace WinDll.Utils +{ + /// <summary> + /// A class to control access to a particulair value, Threadsafe + /// </summary> + public class LockedValue<T> : IDisposable + { + private T value; + private Semaphore sem; + + /// <summary> + /// Create a new LockedValue and allow only 1 thing to access it at a time + /// </summary> + /// <param name="value">The value to monitor</param> + public LockedValue(T value):this(value, 1){ + } + + /// <summary> + /// Create a new LockedValue and allow @max@ things to access it at a time + /// </summary> + /// <param name="value">The value to monitor</param> + /// <param name="max"></param> + public LockedValue(T value, int max) + { + this.value = value; + this.sem = new Semaphore(max, 10, "LockedValue" + this.GetHashCode()); + } + + /// <summary> + /// Retreive the LockedValue + /// </summary> + /// <returns>LockedValue</returns> + public T pull() + { + this.sem.WaitOne(); + return this.value; + } + + /// <summary> + /// Release the LockedValue + /// </summary> + public void pulse() + { + this.sem.Release(); + } + + /// <summary> + /// Unsafe retreiving of the value. This should not be used under normal conditions! + /// </summary> + /// <returns>LockedValue</returns> + public T unsafePull() + { + return this.value; + } + + public void Dispose() + { + this.sem.Close(); + } + } +}
+ Includes/FFI/Properties/AssemblyInfo.cs view
@@ -0,0 +1,36 @@+using System.Reflection; +using System.Runtime.CompilerServices; +using System.Runtime.InteropServices; + +// General Information about an assembly is controlled through the following +// set of attributes. Change these attribute values to modify the information +// associated with an assembly. +[assembly: AssemblyTitle("FFI")] +[assembly: AssemblyDescription("C# Utilities functions for interaction with Haskell via FFI")] +[assembly: AssemblyConfiguration("")] +[assembly: AssemblyCompany("zhox corporation")] +[assembly: AssemblyProduct("FFI")] +[assembly: AssemblyCopyright("Copyright © zhox corporation 2010")] +[assembly: AssemblyTrademark("")] +[assembly: AssemblyCulture("")] + +// Setting ComVisible to false makes the types in this assembly not visible +// to COM components. If you need to access a type in this assembly from +// COM, set the ComVisible attribute to true on that type. +[assembly: ComVisible(false)] + +// The following GUID is for the ID of the typelib if this project is exposed to COM +[assembly: Guid("47f57c65-2fb6-4de5-8af7-9c2c6aa8c139")] + +// Version information for an assembly consists of the following four values: +// +// Major Version +// Minor Version +// Build Number +// Revision +// +// You can specify all the values or you can default the Build and Revision Numbers +// by using the '*' as shown below: +// [assembly: AssemblyVersion("1.0.*")] +[assembly: AssemblyVersion("1.0.0.0")] +[assembly: AssemblyFileVersion("1.0.0.0")]
+ Includes/FFI/SafeString.cs view
@@ -0,0 +1,63 @@+using System; +using System.Collections.Generic; +using System.Linq; +using System.Text; + +namespace WinDll.Utils +{ + /// <summary> + /// Just a way to make the constructor also free unmanaged pointers. + /// This saves us from having to make repeated calls ourselves + /// </summary> + public unsafe class SafeString + { + /// <summary> + /// Return a managed string from the char* pointer + /// and then free the pointer + /// </summary> + /// <param name="pointer">The unsafe string pointer</param> + /// <returns>The char* as a managed string</returns> + public unsafe static string Create(char* pointer) + { + string msg = new string(pointer); + FFI.free(pointer); + pointer = null; + return msg; + } + + /// <summary> + /// Return a managed string from the char* pointer + /// and then free the pointer + /// </summary> + /// <param name="pointer">The unsafe string pointer</param> + /// <returns>The void* as a managed string</returns> + public unsafe static string Create(void* pointer) + { + if (pointer == null) return ""; + return Create((char*)pointer); + } + + /// <summary> + /// The representation used most often for marshalling array is to return + /// for every array a tuple. The first element of the tuple is the size of + /// the array and the second element the array itself. + /// </summary> + /// <param name="pointer">The unsafe string array pointer</param> + /// <returns>string array</returns> + public static unsafe string[] CreateArray(Tuples.Tuple2* values) + { + int length = (int)values->tuple2_var1; + string[] result = new string[length]; + char** value = (char**)values->tuple2_var2; + + for (int i = 0; i < length; i++) + { + result[i] = SafeString.Create(value[i]); + } + + FFI.free(values); + + return result; + } + } +}
+ Includes/FFI/WinLib.cs view
@@ -0,0 +1,187 @@+using System; +using System.Runtime.InteropServices; + +namespace WinDll.Utils +{ + + ///*************************************** + /// The Maybe datatype + ///*************************************** + public enum ListMaybe { cMaybeNothing, cMaybeJust }; + + [StructLayout(LayoutKind.Sequential, CharSet = CharSet.Unicode)] + public struct Nothing + { + }; + + [StructLayout(LayoutKind.Sequential, CharSet = CharSet.Unicode)] + public unsafe struct Just + { + public void* maybe_just_var1; + }; + + [StructLayout(LayoutKind.Explicit, CharSet = CharSet.Unicode)] + public struct MaybeUnion + { + [FieldOffset(0)] + public Nothing nothing; + [FieldOffset(0)] + public Just just; + }; + + [StructLayout(LayoutKind.Sequential, CharSet = CharSet.Unicode)] + public unsafe struct Maybe + { + public ListMaybe tag; + public MaybeUnion* elt; + }; + + public unsafe partial class FFI + { + + [DllImport("msvcrt.dll",CallingConvention=CallingConvention.Cdecl,EntryPoint="_msize")] + public unsafe static extern uint _msize(void* obj); + + [DllImport("msvcrt.dll",CallingConvention=CallingConvention.Cdecl,EntryPoint="free", SetLastError =true)] + private unsafe static extern void freeNative(void* obj); + + public unsafe static void free(void* obj) + { + if (obj == null) return; + freeNative(obj); + obj = null; + } + + public static void free(IntPtr ptr) + { + if (ptr != IntPtr.Zero) + free(ptr.ToPointer()); + } + + public static unsafe void freeTuple(Tuples.Tuple3* tuple3) + { + if (tuple3 == null) return; + + FFI.free(tuple3->tuple3_var1); + FFI.free(tuple3->tuple3_var2); + FFI.free(tuple3->tuple3_var3); + FFI.free(tuple3); + tuple3 = null; + } + + public static unsafe void freeTuple(Tuples.Tuple2* tuple2) + { + if (tuple2 == null) return; + + FFI.free(tuple2->tuple2_var1); + FFI.free(tuple2->tuple2_var2); + FFI.free(tuple2); + tuple2 = null; + } + + public static unsafe void* readMaybe(Maybe* value) + { + void* val = null; + switch (value->tag) + { + case ListMaybe.cMaybeNothing: + break; + case ListMaybe.cMaybeJust: + val = value->elt->just.maybe_just_var1; + break; + default: + break; + } + + free(value->elt); + free(value); + + return val; + } + + /// <summary> + /// In an indexed tuple the first element is a normal integer and not a pointer, so we shouldn't try to free it. + /// </summary> + /// <param name="tuple2"></param> + public static unsafe void freeIndexTuple(Tuples.Tuple2* tuple2) + { + if (tuple2 == null) return; + + FFI.free(tuple2->tuple2_var2); + FFI.free(tuple2); + tuple2 = null; + } + + } + + public unsafe class Tuples + { + ///*************************************** + /// The Tuple datatypes + ///*************************************** + + [StructLayout(LayoutKind.Sequential, CharSet = CharSet.Unicode)] + public struct Tuple2 { + public void* tuple2_var1; + public void* tuple2_var2; + }; + + [StructLayout(LayoutKind.Sequential, CharSet = CharSet.Unicode)] + public struct Tuple3 { + public void* tuple3_var1; + public void* tuple3_var2; + public void* tuple3_var3; + }; + + [StructLayout(LayoutKind.Sequential, CharSet = CharSet.Unicode)] + public struct Tuple4 { + public void* tuple4_var1; + public void* tuple4_var2; + public void* tuple4_var3; + public void* tuple4_var4; + }; + + [StructLayout(LayoutKind.Sequential, CharSet = CharSet.Unicode)] + public struct Tuple5 { + public void* tuple5_var1; + public void* tuple5_var2; + public void* tuple5_var3; + public void* tuple5_var4; + public void* tuple5_var5; + }; + + [StructLayout(LayoutKind.Sequential, CharSet = CharSet.Unicode)] + public struct Tuple6 { + public void* tuple6_var1; + public void* tuple6_var2; + public void* tuple6_var3; + public void* tuple6_var4; + public void* tuple6_var5; + public void* tuple6_var6; + }; + + [StructLayout(LayoutKind.Sequential, CharSet = CharSet.Unicode)] + public struct Tuple7 { + public void* tuple7_var1; + public void* tuple7_var2; + public void* tuple7_var3; + public void* tuple7_var4; + public void* tuple7_var5; + public void* tuple7_var6; + public void* tuple7_var7; + }; + + [StructLayout(LayoutKind.Sequential, CharSet = CharSet.Unicode)] + public struct Tuple8 { + public void* tuple8_var1; + public void* tuple8_var2; + public void* tuple8_var3; + public void* tuple8_var4; + public void* tuple8_var5; + public void* tuple8_var6; + public void* tuple8_var7; + public void* tuple8_var8; + }; + + } +}
+ Includes/Instances.h view
@@ -0,0 +1,35 @@+///*************************************** +/// The Maybe datatype +///*************************************** + +enum ListMaybe {cMaybeNothing, cMaybeJust}; + +typedef struct Maybe Maybe_t; +typedef struct Nothing Nothing_t; +typedef struct Just Just_t; + +//struct L; + +struct Nothing { +}; + +struct Just { + void* maybe_just_var1; +}; + +union MaybeUnion { + Nothing_t nothing; + Just_t just; +}; + +struct Maybe { + enum ListMaybe tag; + union MaybeUnion* elt; +}; + +/* +typedef struct L { + struct SrcSpan located_l_var1; + void* located_l_var2; +} Located; +*/
+ Includes/Tuples.h view
@@ -0,0 +1,67 @@+///*************************************** +/// The Tuple datatypes +///*************************************** + +typedef struct Tuple2 Tuple2_t; +typedef struct Tuple3 Tuple3_t; +typedef struct Tuple4 Tuple4_t; +typedef struct Tuple5 Tuple5_t; +typedef struct Tuple6 Tuple6_t; +typedef struct Tuple7 Tuple7_t; +typedef struct Tuple8 Tuple8_t; + +struct Tuple2 { + void* tuple2_var1; + void* tuple2_var2; +}; + +struct Tuple3 { + void* tuple3_var1; + void* tuple3_var2; + void* tuple3_var3; +}; + +struct Tuple4 { + void* tuple4_var1; + void* tuple4_var2; + void* tuple4_var3; + void* tuple4_var4; +}; + +struct Tuple5 { + void* tuple5_var1; + void* tuple5_var2; + void* tuple5_var3; + void* tuple5_var4; + void* tuple5_var5; +}; + +struct Tuple6 { + void* tuple6_var1; + void* tuple6_var2; + void* tuple6_var3; + void* tuple6_var4; + void* tuple6_var5; + void* tuple6_var6; +}; + +struct Tuple7 { + void* tuple7_var1; + void* tuple7_var2; + void* tuple7_var3; + void* tuple7_var4; + void* tuple7_var5; + void* tuple7_var6; + void* tuple7_var7; +}; + +struct Tuple8 { + void* tuple8_var1; + void* tuple8_var2; + void* tuple8_var3; + void* tuple8_var4; + void* tuple8_var5; + void* tuple8_var6; + void* tuple8_var7; + void* tuple8_var8; +};
+ Includes/WinDllSupport.dll view
binary file changed (absent → 15456 bytes)
+ Includes/WinDllSupport.exp view
binary file changed (absent → 908 bytes)
+ Includes/WinDllSupport.h view
@@ -0,0 +1,28 @@+////////////////////////////////////////////// +// __ __ _ ___ __ __ // +// / / /\ \ (_)_ __ / \/ / / / // +// \ \/ \/ / | '_ \ / /\ / / / / // +// \ /\ /| | | | |/ /_// /___/ /___ // +// \/ \/ |_|_| |_/___,'\____/\____/ // +// // +// This software is still BETA software // +// // +// GENERATED BY WinDLL VERSION 0.4.8 // +// DO NOT MODIFY, IF YOU DO THE MARSHALLING // +// MIGHT FAIL BECAUSE OF INCOMPATIBILITIES // +//////////////////////////////////// WinDLL // + +#ifdef _MSC_VER +#define CALLTYPE(x) __declspec(dllimport) x __cdecl +#else +#define CALLTYPE(x) x __attribute__((__cdecl__)) +#endif + +#ifdef __cplusplus +extern "C" { +#endif +extern CALLTYPE(void) freeNative ( void* prt ); + +#ifdef __cplusplus +} +#endif
+ Includes/WinDllSupport.lib view
binary file changed (absent → 2044 bytes)
+ LICENSE.txt view
@@ -0,0 +1,20 @@+Microsoft Public License (MS-PL) + +This license governs use of the accompanying software. If you use the software, you accept this license. If you do not accept the license, do not use the software. + +1. Definitions +The terms "reproduce," "reproduction," "derivative works," and "distribution" have the same meaning here as under U.S. copyright law. +A "contribution" is the original software, or any additions or changes to the software. +A "contributor" is any person that distributes its contribution under this license. +"Licensed patents" are a contributor's patent claims that read directly on its contribution. + +2. Grant of Rights +(A) Copyright Grant- Subject to the terms of this license, including the license conditions and limitations in section 3, each contributor grants you a non-exclusive, worldwide, royalty-free copyright license to reproduce its contribution, prepare derivative works of its contribution, and distribute its contribution or any derivative works that you create. +(B) Patent Grant- Subject to the terms of this license, including the license conditions and limitations in section 3, each contributor grants you a non-exclusive, worldwide, royalty-free license under its licensed patents to make, have made, use, sell, offer for sale, import, and/or otherwise dispose of its contribution in the software or derivative works of the contribution in the software. + +3. Conditions and Limitations +(A) No Trademark License- This license does not grant you rights to use any contributors' name, logo, or trademarks. +(B) If you bring a patent claim against any contributor over patents that you claim are infringed by the software, your patent license from such contributor to the software ends automatically. +(C) If you distribute any portion of the software, you must retain all copyright, patent, trademark, and attribution notices that are present in the software. +(D) If you distribute any portion of the software in source code form, you may do so only under this license by including a complete copy of this license with your distribution. If you distribute any portion of the software in compiled or object code form, you may only do so under a license that complies with this license. +(E) The software is licensed "as-is." You bear the risk of using it. The contributors give no express warranties, guarantees or conditions. You may have additional consumer rights under your local laws which this license cannot change. To the extent permitted under your local laws, the contributors exclude the implied warranties of merchantability, fitness for a particular purpose and non-infringement.
+ LIMITS.TXT view
@@ -0,0 +1,25 @@+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 view
@@ -0,0 +1,39 @@+{- @@ 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
@@ -0,0 +1,6 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> import qualified Tests.TestRunner as TR++> main = defaultMainWithHooks simpleUserHooks { runTests = TR.runPkgTestsHook }
+ Templates/main.template-unix.c view
@@ -0,0 +1,26 @@+#include <Rts.h>++extern void __stginit_%name(void);++HsBool __attribute__ ((constructor)) %name_load(void);+void __attribute__ ((destructor)) %name_unload(void);++HsBool %name_load(void){+ int argc = 1;+ char *argv[] = { "ghcDll", NULL };+ /* N.B. argv arrays must end with NULL */++ // Initialize Haskell runtime+ hs_init(&argc, &argv);++ // Tell Haskell about all root modules+ hs_add_root(__stginit_%name);++ // do any other initialization here and+ // return false if there was a problem+ return HS_BOOL_TRUE;+}++void %name_unload(void){+ hs_exit();+}
+ Templates/main.template-win.c view
@@ -0,0 +1,23 @@+#include <windows.h>+#include <Rts.h>++extern void __stginit_%name(void);++static char* args[] = { "ghcDll", NULL };+ /* N.B. argv arrays must end with NULL */+BOOL+%callconv+DllMain+ ( HANDLE hModule+ , DWORD reason+ , void* reserved+ )+{+ if (reason == DLL_PROCESS_ATTACH) {+ /* By now, the RTS DLL should have been hoisted in, but we need to start it up. */+ startupHaskell(1, args, __stginit_%name);+ return TRUE;+ }+ return TRUE;+}+
+ Templates/nomain.template-unix.c view
@@ -0,0 +1,21 @@+#include <Rts.h> + +extern void __stginit_%name(void); + +void HsStart(void) +{ + int argc = 1; + char* argv[] = {"ghcDll", NULL}; // argv must end with NULL + + // Initialize Haskell runtime + char** args = argv; + hs_init(&argc, &args); + + // Tell Haskell about all root modules + hs_add_root(__stginit_%name); +} + +void HsEnd(void) +{ + hs_exit(); +}
+ Templates/nomain.template-win.c view
@@ -0,0 +1,22 @@+#include <windows.h> +#include <Rts.h> + +extern void __stginit_%name(void); + +void %callconv HsStart(void) +{ + int argc = 1; + char* argv[] = {"ghcDll", NULL}; // argv must end with NULL + + // Initialize Haskell runtime + char** args = argv; + hs_init(&argc, &args); + + // Tell Haskell about all root modules + hs_add_root(__stginit_%name); +} + +void %callconv HsEnd(void) +{ + hs_exit(); +}
+ Tests/FindFiles.hs view
@@ -0,0 +1,40 @@+module Tests.FindFiles (findFiles, findAllFiles) where++import Control.Monad+import Data.List+import Directory+import System.FilePath++-- concatMapM, partitionM: pull out into monad utility lib? Does some version+-- of these already exist somewhere?+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f = liftM concat . mapM f+ +-- Performs monadic predicate on list and partitions the result into two lists.+-- I don't think we can use partition p xs = (filter p xs, filter (not . p) xs)+-- as an implementation guide since we only want to run the predicate+-- actions once.+partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM p xs = mapM p xs >>= \bools -> return $ partition' bools xs [] []+ where partition' :: [Bool] -> [a] -> [a] -> [a] -> ([a], [a])+ partition' _ [] yes no = (reverse yes, reverse no)+ partition' (b:bs) (x:xs) yes no = if b then partition' bs xs (x:yes) no+ else partition' bs xs yes (x:no)++-- Find all files (recursively) in the given directory matching the predicate f.+findFiles :: FilePath -> (FilePath -> Bool) -> IO [FilePath]+findFiles path f = (liftM (filter f) . findAllFiles) path++-- Big Assumption: every element that isn't a directory is a file! I assume+-- that the Directory functions treat links reasonably, so that everything+-- falls into these two nice neat buckets.+findAllFiles :: FilePath -> IO [FilePath]+findAllFiles path = do elems <- getElems path+ (subdirs, files) <- partitionM doesDirectoryExist elems+ nested_files <- concatMapM findAllFiles subdirs+ return $ files ++ nested_files+ where+ getElems = liftM filterElems . getDirectoryContents+ filterElems = map addPath . filter notDotOrDotDot+ addPath = (path </>)+ notDotOrDotDot = (`notElem` [".", ".."])
+ Tests/Src/Test_ADT.hs view
@@ -0,0 +1,38 @@+module Tests.Src.Test_ADT where++import Data.Char++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] }
+ Tests/Src/Test_AdvanceCall.hs view
@@ -0,0 +1,11 @@+module Tests.Src.Test_AdvanceCall where + +-- @@ Export +myAdd :: (Int -> Int) -> Int -> Int +myAdd = ($) + +data Callback = Callback { ptr :: Int -> Int } + +-- @@ Export +yourAdd :: Callback +yourAdd = Callback { ptr = \t -> t + t }
+ Tests/Src/Test_AdvancedListCall.hs view
@@ -0,0 +1,19 @@+module Tests.Src.Test_AdvancedListCall where + +-- @@ Export +summerize :: [Int] -> [Int] -> Int +summerize x y = sum $ x ++ y + +-- @@ Export +single :: Int -> [Int] +single x = [1..x] + +-- @@ Export +-- | Simple function to test higher-order +-- functions with lists. +ply :: Int -> (Int -> [Int] -> [Int]) -> Int +ply x f = summerize (f x []) (f x []) + +-- @@ Export +unPly :: Int -> ([Int] -> Int) -> Int +unPly i f = f [i]
+ Tests/Src/Test_AdvancedListCallbacks.hs view
@@ -0,0 +1,21 @@+module Tests.Src.Test_AdvancedListCallbacks where + +-- @@ Export +summerize :: [Int] -> [Int] -> Int +summerize x y = sum $ x ++ y + +-- @@ Export +single :: Int -> [Int] +single x = [1..x] + +-- @@ Export +-- | Simple function to test higher-order +-- functions with lists. +ply :: Int -> (Int -> [Int] -> [Int]) -> Int +ply x f = summerize (f x []) (f x []) + +data MyPly = MyPly { unPly :: Int -> [Int] -> [Int] } + +-- @@ Export +myPly :: Int -> MyPly -> Int +myPly x m = summerize (unPly m x []) (unPly m x [])
+ Tests/Src/Test_AdvancedListTests.hs view
@@ -0,0 +1,28 @@+module Tests.Src.Test_AdvancedListTests where + +-- @@ Export +summerize :: [Int] -> [Int] -> Int +summerize x y = sum $ x ++ y + +-- @@ Export +single :: Int -> [Int] +single x = [1..x] + +-- @@ Export +-- | Simple function to test higher-order +-- functions with lists. +ply :: Int -> (Int -> [Int] -> [Int]) -> Int +ply x f = summerize (f x []) (f x []) + +-- @@ Export +myPly :: Int -> MyPly -> Int +myPly x m = summerize (unPly m x []) (unPly m x []) + +data MyPly = MyPly { unPly :: Int -> [Int] -> [Int] + , ploo :: [Int]} + +-- @@ Export +munch :: Int -> MyPly +munch i = MyPly { ploo = [i] + , unPly = (:) + }
+ Tests/Src/Test_Bewijzen.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE DeriveDataTypeable #-} +module Tests.Src.Test_Bewijzen where + +import Data.Data +import Data.Generics +import Data.List +import Data.Char +import Data.Maybe +import Control.Monad +import Debug.Trace + +data Prop = Var Var + | F + | T + | Not Prop + | And Prop Prop + | Or Prop Prop + | Impl Prop Prop + deriving (Show,Data,Typeable) + +type PropAlgebra a = (Var -> a + , a + , a + , a -> a + , a -> a -> a + , a -> a -> a + , a -> a -> a) + +type Var = String + +demo = Var "p" `And` (Not (Var "q") `Or` (Var "r")) + +foldProp :: PropAlgebra a -> Prop -> a +foldProp (var_,f_,t_,not_,and_,or_,impl_) prop = foldalgebra prop + where foldalgebra prop = + case prop of + (Var v) -> var_ v + F -> f_ + T -> t_ + (Not p) -> not_ (foldalgebra p) + (And p1 p2) -> (foldalgebra p1) `and_` (foldalgebra p2) + (Or p1 p2) -> (foldalgebra p1) `or_` (foldalgebra p2) + (Impl p1 p2) -> (foldalgebra p1) `impl_` (foldalgebra p2) + +-- @@ Export +ppProp :: Prop -> String +-- ppProp (Var p) = p +-- ppProp (Not p) = "Not " ++ ppProp p +-- ppProp (And p1 p2) = "And " ++ ppProp p1 ++ " " ++ ppProp p2 +-- ppProp (Or p1 p2) = "Or " ++ ppProp p1 ++ " " ++ ppProp p2 +-- ppProp (Impl p1 p2) = "Impl " ++ ppProp p1 ++ " " ++ ppProp p2 +-- ppProp T = "T" +-- ppProp F = "F" +-------------------------------------- +-- -- OR using folds +-------------------------------------- +-- ppProp = foldProp (id, + -- "F", + -- "T", + -- ("Not "++), + -- (\a b->"And "++a++" "++b), + -- (\a b->"Or "++a++" "++b), + -- (\a b->"Impl "++a++" "++b) + -- ) +-------------------------------------- +-- -- OR using Scrap Your Boilerplate +-------------------------------------- +ppProp = init.everything (++) ([] `mkQ` inner) + where inner (Var p) = p ++ " " + inner x = (showConstr.toConstr) x ++ " " + +-- @@ Export=ppPropPrime +ppProp' :: Prop -> String +ppProp' = foldProp (id, + "F", + "T", + (++" Not"), + (\a b->a++" "++b++" And"), + (\a b->a++" "++b++" Or"), + (\a b->a++" "++b++" Impl") + ) + +-- @@ Export +parseVar :: String -> Maybe (Var,String) +parseVar input = + do let (a,v) = head $ lex input + case (all isLower a) of + False -> Nothing + True -> Just (a,v) + +-- @@ Export +parseProp :: String -> Maybe Prop +parseProp input = let result = parseProp' input + in if null result + then Nothing + else case head result of + (val,[]) -> val + _ -> Nothing + where + parseProp' :: ReadS (Maybe Prop) + parseProp' x = + do let (hd,r1) = head $ lex x + when (null hd) (error "Parse error") + case hd of + "And" -> pp And r1 + "Or" -> pp Or r1 + "Not" -> do let (Just f1,r2) = head $ parseProp' r1 + return (Just $ Not f1,r2) + "Impl" -> pp Impl r1 + "F" -> return (Just F,r1) + "T" -> return (Just T,r1) + y -> return $ maybe (Nothing,x) (\(a,v)->(Just $ Var a,v++r1)) (parseVar y) + where f = fromJust.fst.head + pp cons r1 = do let (Just f1,r2) = head $ parseProp' r1 + let (Just f2,r3) = head $ parseProp' r2 + return (Just $ cons f1 f2,r3) + +-- @@ Export = parsePropPrime +parseProp' :: String -> Maybe Prop +parseProp' input = let result = parseProp'' [] input + in if null result + then Nothing + else case head result of + (val,[]) -> val + _ -> Nothing + where + parseProp'' :: [Prop] -> ReadS (Maybe Prop) + parseProp'' p x = let (hd,r1) = head $ lex x + in if (null hd) + then if length p == 1 then return (Just $ head p,"") else [] + else + do case hd of + "And" -> pp And r1 + "Or" -> pp Or r1 + "Not" -> do let (f1:[]) = take 1 p + rest = drop 1 p + parseProp'' (Not f1:rest) r1 + "Impl" -> pp Impl r1 + "F" -> parseProp'' (F:p) r1 + "T" -> parseProp'' (T:p) r1 + y -> maybe [(Nothing,x)] (\(a,v)->parseProp'' (Var a:p) (v++r1)) (parseVar y) + where f = fromJust.fst.head + pp cons r1 = do if length p < 2 + then [] + else let (f1:f2:[]) = take 2 p + rest = drop 2 p + in parseProp'' (cons f2 f1:rest) r1 + +-- @@ Export = getVars +vars :: Prop -> [Var] +vars = nub.foldProp ((:[]),[],[],id,(++),(++),(++)) + +type Env = Var -> Bool + +--truthTable :: [Var] -> [Env] +--truthTable input = [ , a <- input, b <- input, c <- input , d <- [True,False]] +-- where m b = case a + +f "p" = True +f "q" = False +f "r" = True +
+ Tests/Src/Test_Getallen.hs view
@@ -0,0 +1,153 @@+module Tests.Src.Test_Getallen where + +import Data.List +import Data.Maybe +import Control.Monad +import Control.Arrow + + + +unfoldl :: (t -> Maybe (a, t)) -> t -> [a] +unfoldl f x = case f x of + Nothing -> [] + Just (u,v) -> unfoldl f v ++ [u] -- we miss you wli + +-- @@ Export +-- | This is a reverse of the original divMod function, it's useful with unfoldl +modDiv :: Integer -> Integer -> (Integer, Integer) +modDiv = \a -> (snd &&& fst).(divMod a) + +-- @@ Export +-- | calculate the decimal representation of a number from it's components +-- . +-- e.g. fromDec [1,2,3] = 123 +-- . +-- The inverse of toDec +fromDec :: [Integer] -- ^ The list of decimal numbers to combine + -> Integer -- ^ The combined representation of the input +fromDec = foldl' ((+).(*10)) 0 + +-- @@ Export +-- | calculate from a decimal number it's components +-- . +-- e.g. toDec 123 = [1,2,3] +-- . +-- The inverse of fromDec +toDec :: Integer -- ^ The decimal number to break into it's sub components + -> [Integer] -- ^ The result from decomposing the input +toDec 0 = [0] +-- toDec x = (reverse.(unfoldr (\a-> let b = a `mod` 10 + -- in if a == 0 then Nothing + -- else Just (b,(a-b) `div` 10)))) x +toDec x = unfoldl (\x -> guard (x /= 0) >> return (x `modDiv` 10)) x + +-- @@ Export +-- | Calculate from a list of binary digits the corresponding decimal number +-- . +-- e.g. fromBin [1,0,1] = 5 +-- . +-- The inverse of toBin +fromBin :: [Integer] -- ^ The list of bits to convert + -> Integer -- ^ The resulting nnumber converted from binary +fromBin x = fromBin' (length x - 1) x + where fromBin' _ [] = 0 + fromBin' c (x:xs) = x*2^c + fromBin' (c-1) xs + +-- @@ Export +-- | Calculate from a decimal number the corresponding binary digit components +-- . +-- e.g. toBin 5 = [1,0,1] +-- . +-- The inverse of fromBin +toBin :: Integer -- ^ The input number to convert to binary + -> [Integer] -- ^ The list consisting of the bits of the computation +toBin 0 = [0] +toBin x = (unfoldl (\a -> guard (a /= 0) >> return (a `modDiv` 2))) x +-- toBin = reverse.(unfoldr (\a -> if a == 0 then Nothing + -- else let b = a `mod` 2 + -- in Just (b,a `div` 2))) + +-- @@ Export = fromBaseMaybe +-- | Calculate given the base and the input string with the number to encode +-- the corresponding encoding. +-- . +-- e.g. fromBase2 2 "101" = Just 5 +-- . +-- This can ofcourse fail, to encode this there's a Maybe in the return type. +-- . +-- e.g. fromBase2 1 "101" = Nothing +fromBase2 :: Int -- ^ The numerical base + -> String -- ^ The input string to convert + -> Maybe Int -- ^ The result of the conversion, which may have failed +fromBase2 b i = fromBase' (take b $ ['0'..'9']++['a'..'z']) (length i-1) i + where fromBase' _ _ [] = Just 0 + fromBase' a i (x:xs) = let val = (elemIndex x a) + rec_ = fromBase' a (i-1) xs + in liftM2 (+) (fmap (*b^i) val) rec_ + +-- @@ Export +-- | A version of fromBase2 (fromBaseMaybe) where failure is not encoded. +-- If it fails it'll produce a crash. +-- . +-- see fromBase2 (fromBaseMaybe) +-- . +-- The inverse of toBase +fromBase :: Int -- ^ The numerical base to use + -> String -- ^ The number to convert + -> Int -- ^ The converted number to the destination base +fromBase a b= fromJust (fromBase2 a b) + +-- @@ Export +-- | A encode a number using the given base. The result is encoded into a string. +-- . +-- e.g. toBase 2 5 = "101" +-- . +-- . The inverse of fromBase +toBase :: Int -- ^ The numerical base to use + -> Int -- ^ The number to convert + -> String -- ^ The converted number to the destination base +toBase b = toBase' (take b $ ['0'..'9']++['a'..'z']) + where toBase' d i = case i of + 0 -> "0" + _ -> (unfoldl (\a -> guard (a /= 0) >> return ( d !! (a `mod` b),a `div` b))) i + +-- @@ Export +-- | Calculate the result of converting the list of strings using the given base into a tuple +-- . +-- which contains the (input, representation) +-- . +-- this is done using fromBase2. Encodings that fail will simple not be included in the resulting list. +-- . +-- numbers 2 ["101010","10101"] = [("101010",42),("10101",21)] +-- . +-- numbers 2 ["12345" ,"10101"] = [("10101",21)] +numbers :: Int -- ^ The numerical base + -> [String] -- ^ The list of number to convert to the given base. + -> [(String,Int)] -- ^ The result of the conversion, the first part of the tuple is the original input and the second part the converted number +numbers b i = mapMaybe (uncurry (fmap . (,))) $ zip i (fmap (fromBase2 b) i) + +grayCode :: Int -> (String -> Int, Int -> String) +grayCode base = (fromBase base,toBase base) + +lookAndSay :: Int -> [String] +lookAndSay x = look (show x) + where look :: String -> [String] + look y = let lst = group y + res = concatMap (\x->show (length x) ++ [head x]) lst + in y:look res + +keithGetallen :: [Integer] +keithGetallen = [x | x <- [10..], genNumberSec x] + +-- @@ Export +-- | Checks to see if a number is a valid keith number. +genNumberSec :: Integer -- ^ The number to check whether it's a keith number or not + -> Bool -- ^ The answer to whether the number given as input is a keith number +genNumberSec xo = gen no + where gen x = let res = sum (drop (length x-n) x) + in case compare res xo of + GT -> False + EQ -> True + LT -> gen (x++[res]) + no = toDec xo + n = length no
+ Tests/Src/Test_IO.hs view
@@ -0,0 +1,22 @@+module Tests.Src.Test_IO where++-- @@ Export+summerize :: [Int] -> [Int] -> Int+summerize x y = sum $ x ++ y++-- @@ Export+single :: Int -> [Int]+single x = [1..x]++-- @@ Export+singleIO :: Int -> IO [Int]+singleIO = return . single++-- @@ Export+add :: (Int -> Int) -> Int -> Int+add = ($)++-- @@ Export+addIO :: (Int -> IO [Int]) -> Int -> IO Int+addIO f v = do res <- f v+ return $ sum res
+ Tests/Src/Test_SimpleCall.hs view
@@ -0,0 +1,5 @@+module Tests.Src.Test_SimpleCall where + +-- @@ Export +myadd :: (Int -> Int) -> Int -> Int +myadd = ($)
+ Tests/Src/Test_SimpleLists.hs view
@@ -0,0 +1,9 @@+module Tests.Src.Test_SimpleLists where + +-- @@ Export +summerize :: [Int] -> [Int] -> Int +summerize x y = sum $ x ++ y + +-- @@ Export +single :: Int -> [Int] +single x = [1..x]
+ Tests/Src/Test_SimpleTuple.hs view
@@ -0,0 +1,33 @@+module Tests.Src.Test_SimpleTuple where + +-- @@ Export +simpleTuple :: (Int, Int) +simpleTuple = (1, 5) + +-- @@ Export +stringTuple :: (String, String) +stringTuple = ("Foo", "Bar") + +-- @@ Export +threeTuple :: (Int, Int, Int) +threeTuple = (1, 30, 50) + +-- @@ Export +complexTuple :: String -> (String, Maybe String) +complexTuple x = (x, Just x) + +-- @@ Export +inamTuple :: (Int, [String]) +inamTuple = (2, replicate 2 "Hello World") + +data MyTuple a b c = MyTuple a b c + +-- @@ Export +myTuple :: MyTuple Int Int Int +myTuple = MyTuple 1 30 50 + +data MaybeP a = NothingP + +-- @@ Export +maybeTuple :: MaybeP (Int, [String]) +maybeTuple = NothingP
+ Tests/Src/Test_SimpleType.hs view
@@ -0,0 +1,39 @@+-- | A sample test function that my tool has to be able to convert to be usefull+module Tests.Src.Test_SimpleType where++import Control.Monad+import Control.Monad.Instances++data SimpleType = SimpleType { value :: Int, name :: String }+ deriving Show+data Selector = First + | Second+ deriving Show+data TwoCases = NoFields+ | Other SimpleType+ deriving Show + +newtype Foo = Bar String+ deriving Show++-- @@ Export+foo :: Int -> String -> String +foo = const id++-- @@ Match to BAR+-- @@ LOL+-- @@ Export = rachel+-- | This function calculates the value \x->x*x+bar :: Int -> Int+bar = join (*)++-- @@ NO MATCH+ +-- @@ Export+typeTest1 :: Int -> String -> SimpleType+typeTest1 i s = SimpleType i s++-- @@ Export +typeTest2 :: Selector -> TwoCases+typeTest2 First = NoFields+typeTest2 Second = Other (SimpleType 0 "Type Testing")
+ Tests/Src/Test_StateDemo.hs view
@@ -0,0 +1,41 @@+{- @@ IMPORT "Data.IORef" "Foreign.StablePtr" @@ -} +module Tests.Src.Test_StateDemo where + +import Foreign.StablePtr +import Data.IORef + +type Context a = StablePtr (IORef a) +type Env = Context [Int] + +-- @@ Export +initEnv :: IO Env +initEnv = newStablePtr =<< newIORef [] + +-- @@ Export +freeEnv :: Env -> IO () +freeEnv = freeStablePtr + +-- @@ Export +add :: Env -> Int -> IO () +add env val + = do env_value <- deRefStablePtr env + modifyIORef env_value ((val:) $!) + +-- @@ Export = sumPrime +sum' :: Env -> IO Int +sum' env + = do env_value <- deRefStablePtr env + current <- readIORef env_value + return $ sum current + +main :: IO Int +main + = do env <- initEnv + add env 1 + add env 1 + add env 1 + add env 1 + val <- sum' env + freeEnv env + return val +
+ Tests/Src/Test_Validation.hs view
@@ -0,0 +1,170 @@+{-# LINE 24 "Validation.lhs" #-}+{-# OPTIONS -Wall -fno-warn-type-defaults #-}++module Tests.Src.Test_Validation where++import Data.Char+import Data.List+{-# LINE 148 "Validation.lhs" #-}+-- @@ Export+toDigitsRev :: Integer -> [Integer]+{-# LINE 154 "Validation.lhs" #-}+-- @@ Export+toDigits :: Integer -> [Integer]+{-# LINE 158 "Validation.lhs" #-}+-- @@ Export+toDigitsRev = reverse . toDigits+{-# LINE 176 "Validation.lhs" #-}+-- @@ Export+doubleSecond :: [Integer] -> [Integer]+{-# LINE 192 "Validation.lhs" #-}+-- @@ Export+sumDigits :: [Integer] -> Integer+{-# LINE 207 "Validation.lhs" #-}+-- @@ Export+validate :: Integer -> Bool+{-# LINE 237 "Validation.lhs" #-}+-- @@ Export+readCC :: String -> Integer+{-# LINE 254 "Validation.lhs" #-}+-- @@ Export+showCC :: Integer -> String+{-# LINE 291 "Validation.lhs" #-}+-- @@ Export+lookupIssuer :: String -> Integer -> IO String+{-# LINE 328 "Validation.lhs" #-}+-- @@ Export+checkCC :: String -> IO ()+{-# LINE 370 "Validation.lhs" #-}+-- @@ Export+toDigitsRevG :: Integer -> Integer -> [Integer]+{-# LINE 396 "Validation.lhs" #-}+toDigitsRev' :: Integer -> [Integer]+toDigitsRev' 0 = [0]+toDigitsRev' num = go (abs num)+ where+ go 0 = []+ go n = r : go q+ where (q, r) = quotRem n 10++toDigits = reverse . toDigitsRev'++-- Tricky cases:+-- * base too small+-- * num == minBound+toDigitsRevG base num+ | base < 2 = []+ | abs num >= 0 && abs num < base = abs num : []+ | num < 0 = let (q, r) = quotRem num base in negate r : go (negate q) + | otherwise = let (q, r) = quotRem num base in r : go q+ where+ go n+ | n < base = n : []+ | otherwise = let (q, r) = quotRem n base in r : go q++toDigitsRevG' :: (Integral a) => a -> a -> [a]+toDigitsRevG' base num+ | base < 2 = []+ | num == 0 = [0]+ | otherwise = map fromInteger . go . abs $ toInteger num+ where+ go 0 = []+ go n = r : go q+ where (q, r) = quotRem n (toInteger base)++doubleSecond = go1+ where+ d x = x + x+ go1 [] = []+ go1 (x:xs) = x : go2 xs+ go2 [] = []+ go2 (x:xs) = d x : go1 xs++sumDigits = sum . concatMap toDigitsRev++validate n = s `mod` 10 == 0+ where+ d1 = toDigitsRev n+ d2 = doubleSecond d1+ s = sumDigits d2++ds :: String -> String+ds = dropWhile isSpace++readCC s = read s3 * (10 ^ 12) + read s2 * 10 ^ 8 + read s1 * 10 ^ 4 + read s0+ where+ (s3, s210) = splitAt 4 (ds s)+ (s2, s10) = splitAt 4 (ds s210)+ (s1, s0r) = splitAt 4 (ds s10)+ s0 = ds s0r++readCC' :: String -> Integer+readCC' s = n3 * (10 ^ 12) + n2 * 10 ^ 8 + n1 * 10 ^ 4 + n0+ where+ (n3, s210):_ = reads (ds s)+ (n2, s10):_ = reads (ds s210)+ (n1, s0r):_ = reads (ds s10)+ (n0, _):_ = reads (ds s0r)++showCC n = s3 ++ " " ++ s2 ++ " " ++ s1 ++ " " ++ s0+ where+ ns = show n+ zs = replicate (16 - length ns) '0'+ s = zs ++ ns+ (s3, s210) = splitAt 4 s+ (s2, s10) = splitAt 4 s210+ (s1, s0) = splitAt 4 s10++lookupIssuer file num = do++ -- Read the file in as String+ text <- readFile file++ -- Transform string lines into triples+ let entries = toEntries text++ -- Account for longer prefixes that override shorter ones by doing a+ -- reverse lexicographical sort on the prefix digits.+ let sorted = reverse $ sort $ entries++ -- Get the possible issuer by searching the sorted entries until we arrive at+ -- one that matches the prefix of the number and matches the length.+ let issuer = toIssuer sorted num++ -- Account for unknown issuer+ case issuer of+ [] -> return "Unknown"+ name:_ -> return name++-- Format entries as [(<prefix digits>, <length>, <issuer>)]+toEntries :: String -> [([Integer], Int, String)]+toEntries text = do+ ln <- lines text+ (prefix, rest) <- reads ln+ let prefixDigits = toDigits prefix+ (expectedLength, _:issuer) <- reads rest+ return (prefixDigits, expectedLength, issuer)++toIssuer :: [([Integer], Int, String)] -> Integer -> [String]+toIssuer entries num = do+ (prefixDigits, expectedLength, issuer) <- entries+ if prefixMatch prefixDigits numDigits && expectedLength == numLength+ then return issuer+ else []+ where+ prefixMatch xs ys = and $ zipWith (==) xs ys+ numDigits = toDigits num+ numLength = length numDigits+++checkCC file = do+ putStr "Enter credit card number: "+ numText <- getLine+ let numIn = readCC numText+ issuer <- lookupIssuer file numIn+ let s1 = "The number " ++ showCC numIn ++ " is "+ let s2 = if validate numIn+ then ("valid and the type is " ++ issuer ++ ".")+ else ("not a valid credit card number.")+ putStrLn (s1 ++ s2)+ checkCC file
+ Tests/Src/data.txt view
@@ -0,0 +1,19 @@+34 15 American Express+37 15 American Express+560221 16 Bankcard+5610 16 Bankcard+6011 16 Discover Card+65 16 Discover Card+51 16 Master Card+52 16 Master Card+55 16 Master Card+4 13 Visa+4 16 Visa+417500 16 Visa Electron+3528 16 JCB+3530 16 JCB+3566 16 JCB+5019 16 Dankort+633110 16 Switch+305 14 Diners Club+38 14 Diners Club
+ Tests/TestRunner.hs view
@@ -0,0 +1,62 @@+-- | The @TestSupport.TestRunner@ module is used to automatically run unit tests.+--+-- Design here is by convention: we will look for tests in the "Test" subdirectory of this package only,+-- and tests are assumed to be Haskell source files (.hs or .lhs) whose filenames start with "Test".+-- Each is assumed to contain its own @main@ function, and to be runnable as an independent application+-- 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++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 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\\"++-- | Automatically runs tests in the package.+--+-- runTests looks for all Haskell source files in the given subdirectory whose filename starts with \"Test\".+-- These are assumed to be the tests. Each is assumed to contain its own @main@ function, and to be runnable+-- as an independent application without command line arguments.+--+-- 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+ where isTest :: FilePath -> Bool+ isTest fpath = let filename = (takeFileName fpath)+ in "Test_" `isPrefixOf` filename && ".hs" `isSuffixOf` filename++-- | Runs a test. The test is assumed to contain its own @main@ function, and to be runnable as an independent+-- application without command line arguments.+--+-- This uses runhaskell to execute tests, which it assumes is already on the system path.+--+-- /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 ()+ -- >> system ("hs2lib -v2 " ++ test ++ " > " ++ test ++ ".log") >> return ()
+ WinDll/Builder.hs view
@@ -0,0 +1,92 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Contains a pipeline to be used for the process of writing a file to disk+--+-----------------------------------------------------------------------------++module WinDll.Builder where++import WinDll.Session+import WinDll.Utils.Feedback+import WinDll.CmdArgs+import WinDll.Version++import Control.Monad++import System.IO.Error+import System.Random+import System.FilePath+import System.Directory++type Component = Exec ()+type Robot = FilePath -> Exec String -> Component++-- | Create a Component from a robot+createComponent :: Robot+createComponent file robot = + do session <- get+ let build = pipeline session+ fullfile = dirPath build ++ file + value <- robot+ inform _normal ("*** Writing " ++ fullfile ++ "...")+ result <- liftIO $ try $ writeFile fullfile value+ case result of+ Left err -> die ("Error when creating component '" ++ file ++ "': \n\t" ++ show err)+ Right _ -> return ()+ put $ session { pipeline = build { files = file:(files build) } }+ + +-- | Shorter alias for createComponent+cc :: Robot+cc = createComponent+ +-- | Create a new folder to store temp files in and updates the temp path+initialize :: Component+initialize = + do session <- get+ nums <- liftIO $ randomRIO (0::Int,1000000)+ let dir = (tempDIR session) ++ namespace session ++ show nums ++ [pathSeparator]+ inform _normal ("*** Creating directory " ++ dir ++ "...")+ liftIO $ createDirectoryIfMissing True dir+ let build = pipeline session+ output = if null (outputFile session)+ then case platform session of+ Unix -> namespace session ++ ".a"+ Windows -> namespace session ++ ".dll"+ else outputFile session+ odir <- case outputDIR session == "." of+ True -> liftIO getCurrentDirectory+ False -> return $ outputDIR session+ + put $ session { pipeline = build { dirPath = dir }+ , outputFile = output+ , outputDIR = odir }+ +-- | A function to run the pipeline given to it, always calls cleanup at the end and initialize at the start+runComponent :: Component -> Exec Bool+runComponent body = initialize >> body >> return True -- >> cleanup >> return True++-- | Generate the header file for the C programs+mkHeader :: String +mkHeader = unlines $ ["//////////////////////////////////////////////"+ ,"// __ __ _ ___ __ __ //"+ ,"// / / /\\ \\ (_)_ __ / \\/ / / / //"+ ,"// \\ \\/ \\/ / | '_ \\ / /\\ / / / / //"+ ,"// \\ /\\ /| | | | |/ /_// /___/ /___ //"+ ,"// \\/ \\/ |_|_| |_/___,'\\____/\\____/ //"+ ,"// //"+ ,"// This software is still BETA software //"+ ,"// //"+ ,"// GENERATED BY WinDLL VERSION "++ verStr ++ " //"+ ,"// DO NOT MODIFY, IF YOU DO THE MARSHALLING //"+ ,"// MIGHT FAIL BECAUSE OF INCOMPATIBILITIES //"+ ,"//////////////////////////////////// WinDLL //"+ ]
+ WinDll/COFF/Lib.hs view
@@ -0,0 +1,405 @@+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Generates the .lib file for use in c++ compilers.+-- This version can only read and generate the short version of+-- the Import Library format. The Compiler should be able to generate+-- the rest. Or you can use libtool or lib yourself to generate one.+-- http://kishorekumar.net/pecoff_v8.1.htm+--+-----------------------------------------------------------------------------++module WinDll.COFF.Lib where++import Control.Applicative (many)+import Control.Monad (replicateM)+import Control.Monad (when, replicateM)+import Control.Monad.Trans (liftIO)++import Data.Bits+import Data.Char (ord, chr)+import Data.Serialize+import Data.Time.Clock (UTCTime)+import Data.Time.Format (formatTime, readTime)+import Data.Word++import System.Locale (defaultTimeLocale) ++-- | The structure of a .LIB file in Haskell format+data LibFile = LibFile { fstLinker :: Section FirstMember -- ^ @entries@ First linker object+ , sndLinker :: Section SecondMember -- ^ @entries@ second linker object+ , long :: Section LongNames -- ^ @long@ Definition of Longnames ember+ , objfiles :: [Section ImportLibrary] -- ^ @objfiles@ A list of OBJ File contents (COFF Format)+ }+ +-- | The header file of a .LIB COFF format +data Header = Header { hdName :: Either String Int -- ^ 0 16 Name The name of the archive member, with a slash (/) appended + -- to terminate the name. If the first character is a slash, + -- the name has a special interpretation, as described in the + -- following table. + , hdDate :: UTCTime -- ^ 16 12 Date The date and time that the archive member was created: This + -- is the ASCII decimal representation of the number of seconds + -- since 1/1/1970 UCT. + , hdUserID :: String -- ^ 28 6 User ID An ASCII decimal representation of the user ID. This field + -- does not contain a meaningful value on Windows platforms because + -- Microsoft tools emit all blanks. + , hdGroupID :: String -- ^ 34 6 Group ID An ASCII decimal representation of the group ID. This field + -- does not contain a meaningful value on Windows platforms because+ -- Microsoft tools emit all blanks. + , hdMode :: String -- ^ 40 8 Mode An ASCII octal representation of the members file mode. This is + -- the ST_MODE value from the C run-time function _wstat. + , hdSize :: Int -- ^ 48 10 Size An ASCII decimal representation of the total size of the archive + -- member, not including the size of the header. + }+ +-- | The first COFF linker member +data FirstMember = FirstMember { flkOffsets :: [Int] -- ^ 4 4*n Offsets An array of file offsets to archive member headers, in which n is equal+ -- to the Number of Symbols field. Each number in the array is an unsigned + -- long stored in big-endian format. For each symbol that is named in the + -- string table, the corresponding element in the offsets array gives the + -- location of the archive member that contains the symbol. + , flkStrTbl :: [String] -- ^ * * String Table A series of null-terminated strings that name all the symbols in + -- the directory. Each string begins immediately after the null character + -- in the previous string. The number of strings must be equal to the + -- value of the Number of Symbols field. + }+data SecondMember = SecondMember { slkOffsets :: [Int] -- ^ 4 4*m Offsets An array of file offsets to archive member headers, arranged in+ -- ascending order. Each offset is an unsigned long. The number m + -- is equal to the value of the Number of Members field. + , slkIndices :: [Int] -- ^ * 2*n Indices An array of 1-based indexes (unsigned short) that map symbol names + -- to archive member offsets. The number n is equal to the Number of + -- Symbols field. For each symbol that is named in the string table, + -- the corresponding element in the Indices array gives an index into + -- the offsets array. The offsets array, in turn, gives the location + -- of the archive member that contains the symbol. + , slkStrTbl :: [String] -- ^ * * String Table A series of null-terminated strings that name all of the symbols + -- in the directory. Each string begins immediately after the null + -- byte in the previous string. The number of strings must be equal + -- to the value of the Number of Symbols field. This table lists all + -- the symbol names in ascending lexical order. + }++-- | List of long names, These will be stored as a null-terminated string +newtype LongNames = LongNames { lnNames :: [String] }++-- | The import library declaration. This version only allows the short version+-- of the specification. and nothing more. The long version requires me to write+-- a symbol table and calculate some data from the dll. This is something best done +-- by vc++ so I'm not going to do it.+data ImportLibrary = ShortImport { siHeader :: ImportHeader+ , siImportName :: String -- ^ Null-terminated import name string+ , siDLLName :: String -- ^ Null-terminated DLL name string + } + +-- | COFF Import Headers +data ImportHeader = ImportHeader { ihSig1 :: MachineType -- ^ 0 2 Sig1 Must be IMAGE_FILE_MACHINE_UNKNOWN. For more information, see section 3.3.1, "Machine Types." + , ihSig2 :: Int -- ^ 2 2 Sig2 Must be 0xFFFF. + , ihVersion :: (Int, Int) -- ^ 4 2 Version The structure version. + , ihMachine :: MachineType -- ^ 6 2 Machine The number that identifies the type of target machine. For more information, see section 3.3.1, "Machine Types." + , ihDateTime :: UTCTime -- ^ 8 4 Time-Date Stamp The time and date that the file was created. + , ihSize :: Int -- ^ 12 4 Size Of Data The size of the strings that follow the header. + , ihHint :: String -- ^ 16 2 Ordinal/Hint Either the ordinal or the hint for the import, determined by the value in the Name Type field. + , ihType :: ImportType -- ^ 18 2 bits Type The import type. For specific values and descriptions, see section 8.2, "Import Type." + , ihNameType :: ImportNameType -- ^ 3 bits Name Type The import name type. For specific values and descriptions, see section "8.3. Import Name Type." + , ihReserved :: Word16 -- ^ 11 bits Reserved Reserved, must be 0. + }+ ++instance Serialize ImportHeader where+ put ih = do put (ihSig1 ih)+ put (toWord16 $ ihSig2 ih)+ let (major,minor) = ihVersion ih+ put (toWord8 major)+ put (toWord8 minor)+ put (ihMachine ih)+ let time = formatTime defaultTimeLocale "%s" (ihDateTime ih)+ put (read time :: Word32)+ put (toWord32 $ ihSize ih)+ mapM_ put (take 2 $ ihHint ih)+ let bits0 = ihReserved ih+ bits1 = case ihType ih of+ IMPORT_CODE -> bits0+ IMPORT_DATA -> bits0 `setBit` 14+ IMPORT_CONST -> bits0 `setBit` 15+ bits2 = case ihNameType ih of+ IMPORT_ORDINAL -> bits1+ IMPORT_NAME -> bits1 `setBit` 11+ IMPORT_NAME_NOPREFIX -> bits1 `setBit` 12+ IMPORT_NAME_UNDECORATE -> bits1 `setBit` 11 `setBit` 12+ put bits2+ get = do sig1 <- get+ when (sig1 /= IMAGE_FILE_MACHINE_UNKNOWN) $+ error "Import header sig1 error, expected IMAGE_FILE_MACHINE_UNKNOWN"+ sig2 <- get :: Get Word16+ when (sig2 /= 0xFFFF) $+ error "Import Header bit signature mismatch"+ major <- get :: Get Word8+ minor <- get :: Get Word8+ machine <- get+ time <- get :: Get Word32+ let time' = readTime defaultTimeLocale "%s" (show time)+ size <- get :: Get Word32+ hint <- get >>= \a -> get >>= \b -> return [a,b]+ bits0 <- get :: Get Word16+ let itype = case (bits0 `testBit` 14, bits0 `testBit` 15) of+ (False, False) -> IMPORT_CODE+ (True , False) -> IMPORT_DATA+ (False, True ) -> IMPORT_CONST+ iname = case (bits0 `testBit` 11, bits0 `testBit` 12) of+ (False, False) -> IMPORT_ORDINAL+ (True , False) -> IMPORT_NAME+ (False, True ) -> IMPORT_NAME_NOPREFIX+ (True , True ) -> IMPORT_NAME_UNDECORATE+ return $ ImportHeader sig1 (fromWord16 sig2) (fromWord8 major, fromWord8 minor) + machine time' (fromWord32 size) hint itype iname 0++-- | The Machine field has one of the following values that specifies its CPU type. +-- An image file can be run only on the specified machine or on a system that emulates +-- the specified machine.+data MachineType = IMAGE_FILE_MACHINE_UNKNOWN -- ^ 0x0 The contents of this field are assumed to be applicable to any machine type + | IMAGE_FILE_MACHINE_AM33 -- ^ 0x1d3 Matsushita AM33 + | IMAGE_FILE_MACHINE_AMD64 -- ^ 0x8664 x64 + | IMAGE_FILE_MACHINE_ARM -- ^ 0x1c0 ARM little endian + | IMAGE_FILE_MACHINE_EBC -- ^ 0xebc EFI byte code + | IMAGE_FILE_MACHINE_I386 -- ^ 0x14c Intel 386 or later processors and compatible processors + | IMAGE_FILE_MACHINE_IA64 -- ^ 0x200 Intel Itanium processor family + | IMAGE_FILE_MACHINE_M32R -- ^ 0x9041 Mitsubishi M32R little endian + | IMAGE_FILE_MACHINE_MIPS16 -- ^ 0x266 MIPS16 + | IMAGE_FILE_MACHINE_MIPSFPU -- ^ 0x366 MIPS with FPU + | IMAGE_FILE_MACHINE_MIPSFPU16 -- ^ 0x466 MIPS16 with FPU + | IMAGE_FILE_MACHINE_POWERPC -- ^ 0x1f0 Power PC little endian + | IMAGE_FILE_MACHINE_POWERPCFP -- ^ 0x1f1 Power PC with floating point support + | IMAGE_FILE_MACHINE_R4000 -- ^ 0x166 MIPS little endian + | IMAGE_FILE_MACHINE_SH3 -- ^ 0x1a2 Hitachi SH3 + | IMAGE_FILE_MACHINE_SH3DSP -- ^ 0x1a3 Hitachi SH3 DSP + | IMAGE_FILE_MACHINE_SH4 -- ^ 0x1a6 Hitachi SH4 + | IMAGE_FILE_MACHINE_SH5 -- ^ 0x1a8 Hitachi SH5 + | IMAGE_FILE_MACHINE_THUMB -- ^ 0x1c2 Thumb + | IMAGE_FILE_MACHINE_WCEMIPSV2 -- ^ 0x169 MIPS little-endian WCE v2 + deriving (Show, Eq)+ +-- | The following values are defined for the Type field in the import header. +data ImportType = IMPORT_CODE -- ^ 0 Executable code. + | IMPORT_DATA -- ^ 1 Data. + | IMPORT_CONST -- ^ 2 Specified as CONST in the .def file. + +-- | The null-terminated import symbol name immediately follows its associated import header. +-- The following values are defined for the Name Type field in the import header. +-- They indicate how the name is to be used to generate the correct symbols that represent the import.+data ImportNameType = IMPORT_ORDINAL -- ^ 0 The import is by ordinal. This indicates that the value in + -- the Ordinal/Hint field of the import header is the imports + -- ordinal. If this constant is not specified, then the Ordinal/Hint + -- field should always be interpreted as the imports hint.+ | IMPORT_NAME -- ^ 1 The import name is identical to the public symbol name.+ | IMPORT_NAME_NOPREFIX -- ^ 2 The import name is the public symbol name, but skipping the + -- leading ?, @, or optionally _.+ | IMPORT_NAME_UNDECORATE -- ^ 3 The import name is the public symbol name, but skipping the + -- leading ?, @, or optionally _, and truncating at the first @. ++-- | Puts the string of length i. If the string is+-- too short the string is padded, if it's too long+-- the string is truncated.+putString :: Int -> String -> Put+putString i str = let nm = take i (str ++ repeat ' ')+ in mapM_ put nm+ +-- | Reads a fixed length string back in. The string is post+-- processed to removed paddings+getString :: Int -> Get String+getString i = do str <- replicateM i get+ return $ trim str+ +-- | Remove leading and trailing whitespace+trim :: String -> String+trim = reverse . dropWhile (==' ') . reverse . dropWhile (==' ')++-- | Write a NULL terminated string out+writeNullString :: String -> Put+writeNullString str = do mapM_ put str+ put '\0'+ +-- | Read a NULL terminated string+readNullString :: Get String+readNullString = do x <- get+ if x == '\0'+ then return []+ else do xs <- readNullString+ return (x:xs)++-- * Some extra utilities function+toInt :: Functor f => f Word32 -> f Int +toInt = fmap fromIntegral++mapInt :: [Word32] -> [Int]+mapInt = map (fromIntegral :: Word32 -> Int) ++toWord8 :: Integral a => a -> Word8+toWord8 = fromIntegral++toWord16 :: Integral a => a -> Word16+toWord16 = fromIntegral++toWord32 :: Integral a => a -> Word32+toWord32 = fromIntegral++fromWord8 :: Integral a => Word8 -> a+fromWord8 = fromIntegral++fromWord16 :: Integral a => Word16 -> a+fromWord16 = fromIntegral++fromWord32 :: Integral a => Word32 -> a+fromWord32 = fromIntegral+ +instance Serialize LibFile where+ put lib = do mapM_ put "!<arch>\n"+ put (fstLinker lib)+ put (sndLinker lib)+ put (long lib)+ mapM_ put (objfiles lib)+ get = do sig <- getString 08+ when (sig /= "!<arch>\n") $+ error "header value mismatched"+ fstObj <- get+ sndObj <- get+ lngObj <- get+ objFls <- many get+ return $ LibFile fstObj sndObj lngObj objFls+ +instance Serialize Header where+ put hd = do let name = case hdName hd of+ Left str -> str ++ "/"+ Right loc -> '/' : show loc+ putString 16 name+ let time = formatTime defaultTimeLocale "%s" (hdDate hd)+ putString 12 time+ putString 06 (hdUserID hd)+ putString 06 (hdGroupID hd)+ putString 08 (hdMode hd)+ putString 10 (show (hdSize hd))+ put (toWord8 0x60)+ put (toWord8 0x0A)+ get = do name <- getString 16+ time <- getString 12+ user <- getString 06+ group <- getString 06+ mode <- getString 08+ size <- getString 10+ byte1 <- get :: Get Word8+ byte2 <- get :: Get Word8+ let name' = case name of+ '/':str -> Right (read str)+ str -> Left str+ let time' = readTime defaultTimeLocale "%s" time+ when (byte1 /= 0x60 || byte2 /= 0x0A) $+ error "signature bytes mismatch"+ return $ Header name' time' user group mode (read size)++instance Serialize FirstMember where+ put fm = do put (fromIntegral $ length $ flkOffsets fm :: Word32) + mapM_ (put . (fromIntegral :: Int -> Word32)) (flkOffsets fm)+ mapM_ writeNullString (flkStrTbl fm)+ get = do size <- toInt get+ offsets <- replicateM size get :: Get [Word32]+ strTble <- replicateM size readNullString+ return $ FirstMember (mapInt offsets) strTble+ +instance Serialize SecondMember where+ put fm = do put (fromIntegral $ length $ slkOffsets fm :: Word32) + mapM_ (put . (fromIntegral :: Int -> Word32)) (slkOffsets fm)+ put (fromIntegral $ length $ slkIndices fm :: Word32) + mapM_ (put . (fromIntegral :: Int -> Word32)) (slkIndices fm)+ mapM_ writeNullString (slkStrTbl fm)+ get = do size1 <- toInt get+ offsets <- replicateM size1 get :: Get [Word32]+ size2 <- toInt get+ indices <- replicateM size2 get :: Get [Word32]+ strTble <- replicateM size2 readNullString+ return $ SecondMember (mapInt offsets) (mapInt indices) strTble+ +instance Serialize LongNames where+ put = mapM_ writeNullString . lnNames+ get = fmap LongNames $ many readNullString+ +instance Serialize ImportLibrary where+ put im = do put (siHeader im)+ writeNullString (siImportName im)+ writeNullString (siDLLName im)+ get = do header <- get+ impname <- readNullString+ dllname <- readNullString+ return $ ShortImport header impname dllname+ +instance Serialize ImportType where+ put IMPORT_CODE = put (toWord8 0)+ put IMPORT_DATA = put (toWord8 1)+ put IMPORT_CONST = put (toWord8 2)+ get = do val <- get :: Get Word8+ return $ case val of+ 0 -> IMPORT_CODE+ 1 -> IMPORT_DATA+ 2 -> IMPORT_CONST+ +instance Serialize ImportNameType where+ put IMPORT_ORDINAL = put (toWord8 0)+ put IMPORT_NAME = put (toWord8 1)+ put IMPORT_NAME_NOPREFIX = put (toWord8 2)+ put IMPORT_NAME_UNDECORATE = put (toWord8 3)+ get = do val <- get :: Get Word8+ return $ case val of+ 0 -> IMPORT_ORDINAL+ 1 -> IMPORT_NAME+ 2 -> IMPORT_NAME_NOPREFIX+ 3 -> IMPORT_NAME_UNDECORATE++instance Serialize MachineType where+ put IMAGE_FILE_MACHINE_UNKNOWN = put (toWord16 0x0 )+ put IMAGE_FILE_MACHINE_AM33 = put (toWord16 0x1d3 )+ put IMAGE_FILE_MACHINE_AMD64 = put (toWord16 0x8664)+ put IMAGE_FILE_MACHINE_ARM = put (toWord16 0x1c0 )+ put IMAGE_FILE_MACHINE_EBC = put (toWord16 0xebc )+ put IMAGE_FILE_MACHINE_I386 = put (toWord16 0x14c )+ put IMAGE_FILE_MACHINE_IA64 = put (toWord16 0x200 )+ put IMAGE_FILE_MACHINE_M32R = put (toWord16 0x9041)+ put IMAGE_FILE_MACHINE_MIPS16 = put (toWord16 0x266 )+ put IMAGE_FILE_MACHINE_MIPSFPU = put (toWord16 0x366 )+ put IMAGE_FILE_MACHINE_MIPSFPU16 = put (toWord16 0x466 )+ put IMAGE_FILE_MACHINE_POWERPC = put (toWord16 0x1f0 )+ put IMAGE_FILE_MACHINE_POWERPCFP = put (toWord16 0x1f1 )+ put IMAGE_FILE_MACHINE_R4000 = put (toWord16 0x166 )+ put IMAGE_FILE_MACHINE_SH3 = put (toWord16 0x1a2 )+ put IMAGE_FILE_MACHINE_SH3DSP = put (toWord16 0x1a3 )+ put IMAGE_FILE_MACHINE_SH4 = put (toWord16 0x1a6 )+ put IMAGE_FILE_MACHINE_SH5 = put (toWord16 0x1a8 )+ put IMAGE_FILE_MACHINE_THUMB = put (toWord16 0x1c2 )+ put IMAGE_FILE_MACHINE_WCEMIPSV2 = put (toWord16 0x169 )+ get = do val <- get :: Get Word16+ return $ case val of+ 0x0 -> IMAGE_FILE_MACHINE_UNKNOWN + 0x1d3 -> IMAGE_FILE_MACHINE_AM33 + 0x8664 -> IMAGE_FILE_MACHINE_AMD64 + 0x1c0 -> IMAGE_FILE_MACHINE_ARM + 0xebc -> IMAGE_FILE_MACHINE_EBC + 0x14c -> IMAGE_FILE_MACHINE_I386 + 0x200 -> IMAGE_FILE_MACHINE_IA64 + 0x9041 -> IMAGE_FILE_MACHINE_M32R + 0x266 -> IMAGE_FILE_MACHINE_MIPS16 + 0x366 -> IMAGE_FILE_MACHINE_MIPSFPU + 0x466 -> IMAGE_FILE_MACHINE_MIPSFPU16+ 0x1f0 -> IMAGE_FILE_MACHINE_POWERPC + 0x1f1 -> IMAGE_FILE_MACHINE_POWERPCFP+ 0x166 -> IMAGE_FILE_MACHINE_R4000 + 0x1a2 -> IMAGE_FILE_MACHINE_SH3 + 0x1a3 -> IMAGE_FILE_MACHINE_SH3DSP + 0x1a6 -> IMAGE_FILE_MACHINE_SH4 + 0x1a8 -> IMAGE_FILE_MACHINE_SH5 + 0x1c2 -> IMAGE_FILE_MACHINE_THUMB + 0x169 -> IMAGE_FILE_MACHINE_WCEMIPSV2
+ WinDll/CmdArgs.hs view
@@ -0,0 +1,176 @@+-----------------------------------------------------------------------------+-- |+-- 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/CodeGen/C.hs view
@@ -0,0 +1,211 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Generates the needed C code needed by the FFI Calls. +-- +----------------------------------------------------------------------------- + +module WinDll.CodeGen.C where + +import WinDll.CodeGen.Lookup + +import WinDll.Structs.Structures +import WinDll.Utils.Feedback +import WinDll.Builder +import WinDll.Identifier +import WinDll.Session + +import WinDll.Structs.C +import WinDll.Structs.MShow.MShow +import WinDll.Structs.MShow.C +import WinDll.Structs.Folds.HaskellSrcExts + +import WinDll.Utils.HaddockRead + +import Data.List +import Data.Char +import Data.Maybe +import Data.Generics (everywhere,mkT) +import qualified Data.Map as M + +import Control.Monad + +import qualified Language.Haskell.Exts as Exts + +-- | For internal use only. +type CodeGen = CDataType + +-- | Write out the main header file and the definition file for the exports +writeCFiles :: Component +writeCFiles = do inform _normal "Generating C/C++ files for pipeline" + modInfo <- generateMain + session <- get + ann <- makeSessionAnn + let name = namespace session + symb = native_symbols session + spec = (specs.pipeline) session + natives = (n_exports.workingset) session + datatypes = d1++d2 + functions = modFunctions modInfo + (d1 , d2) = modDatatypes modInfo + exports = modExports modInfo + callbacks = modCallbacks modInfo + callconv = call session + defs = natives ++ manualdef + ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) + 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] + else [] + + inform _detail "Creating export definition file" + extra_defs <- liftIO $ fmap (fmap (" "++)) $ mapM readFile symb + createComponent "exports.def" ((return.unlines) (generateExports ann callconv name exports + ++ concatMap (createLocalExports ann) defs + ++ extra_defs)) + + inform _detail "Creating C/C++ structures header file" + 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) + +-- | Generate the export list from a list of defined FFI Export systems +createLocalExports :: Ann -> HaskellExport -> [String] +createLocalExports ann (HaskellExport clp _ (Export _ a t _)) = + case clp of + StdCall -> [" _" ++ a ++ "@" ++ getSize ann t ++ " = " ++ a ++ "@" ++ getSize ann t," " ++ a ++ "@" ++ getSize ann t] + CCall -> [" " ++ a] + +-- | Generate the export list from the list of functions. +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 + +-- | Return the size of a specified type +getSize ann x = let types = createCType (annWorkingSetC ann) x + args = init types + sizes = map (lookupSize (annWorkingSetCSize ann)) args + in show (sum sizes) + +-- | Generate the C extern list from the list of functions. +generateFFIHeader :: Ann -> CallConvention -> String -> [Export] -> [HaskellExport] -> [HaskellExport] -> Exec String +generateFFIHeader ann clp name funcs natives defs + = do session <- get + list <- getDocumentationInfo + -- declare exported functions + let types = concatMap (\(Export _ n t _)-> + let x = createCType (annWorkingSetC ann) t -- genAndLookupC t + restype = last x + rest = case length x > 1 of + True -> init x + False -> [] + names = ["arg"++show n|n<-[1..(length x-1)]] + resp = foldl (\a b->a ++ " " ++ b) "" . lines + args = let value = intercalate ", " (zipWith (\a b->a++" "++b) rest names) + in if null value then " void " else value + in unlines $ [[],"// " ++ n ++ " ::" ++ (resp $ mshowM 2 t)] + ++ maybe [] id (fmap (\x->map ("// "++) (description x)) $ M.lookup n list) ++ + ["extern CALLTYPE(" ++ restype ++ ") " ++ n ++ " (" ++ args ++ ");" + ]) + -- re-export previously reclared export statements + native_declares = let decls = types (map (\(HaskellExport clp _ e) -> e) natives) + in if null natives + then "" + else unlines ["// Preserved export statements", decls] + + -- declare the runtime system control functions (start & stop) + rts_controldecl = let decls = types (map (\(HaskellExport _ _ e) -> e) defs) + in if null defs + then "" + else unlines ["// Runtime control methods", tail decls] + + -- declare the calling convention + mkMacros conven = unlines ["#ifdef _MSC_VER" + ,"#define CALLTYPE(x) __declspec(dllimport) x __" ++ conven + ,"#else" + ,"#define CALLTYPE(x) x __attribute__((__" ++ conven ++ "__))" + ,"#endif"] + return $ unlines $ mkHeader + : ("#include \"" ++ name ++ ".h\"") + : "" + : mkMacros (map toLower (genCcall clp)) + : "#ifdef __cplusplus" + : "extern \"C\" {" + : "#endif" + : rts_controldecl + : types funcs + : native_declares + : ["#ifdef __cplusplus" + ,"}" + ,"#endif"] + +-- | 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 +generateEnum :: DataType -> Maybe DataEnum +generateEnum (DataType name _ t _) = guard (length t > 1) >> return (mkEnum name t) +generateEnum (NewType name _ t _) = Nothing + +-- | 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) + +-- | Generate complete file from given structures +generateHeaderFile :: Ann -> CallConvention -> [Callback] -> DataTypes -> C +generateHeaderFile ann cc cb = (\(a,b,c)->C d_includes cc cb (join a) (join b) (join c)) . unzip3 . map (generateCCode (lookupC (annWorkingSetC ann))) + where d_includes = [LibInclude "string.h" + ,LibInclude "stdint.h" + ,LocalInclude "Instances.h" + ,LocalInclude "Tuples.h" + ] + +-- | Create the Structures and Unions required for the C code along with the enums if needed. +generateCCode :: LookupType -> DataType -> ([DataEnum],[DataField],[DataField]) +generateCCode lc d = (maybeToList (generateEnum d), nub (generateStructs d), generateTopLevelStruct d) + 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 (NewType name e _ _) = [Forward Struct name] + --generateStructs (NewType name e t _) = generateStructs (DataType name e [t] NoTag) + + generateTopLevelStruct :: DataType -> [DataField] + 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] + 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")] + 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) + 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")) + in case annArrayIsList ann of + True -> [base, size] + False -> [base] + mkStruct _ _ = error "mkStruct can only be called with a the 'Const' argument." + + 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)) + + wrapStruct :: CodeGen -> String -> [DataField] -> [DataField] + wrapStruct Struct n l = [Field NormalDef Struct n [] l]-- TypeDef Struct n n l] + wrapStruct Union n l = [Field NormalDef Union n [] l]
+ WinDll/CodeGen/CSharp/CSharp.hs view
@@ -0,0 +1,209 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Generates the needed Haskell code to make calls to the generated DLL+--+-----------------------------------------------------------------------------++module WinDll.CodeGen.CSharp.CSharp where++import WinDll.CodeGen.Lookup+import qualified WinDll.CodeGen.C as CG++import WinDll.Structs.Structures+import WinDll.Utils.Feedback+import WinDll.Builder+import WinDll.Identifier+import WinDll.Session++import WinDll.Structs.C hiding (Normal)+import WinDll.Structs.CSharp+import WinDll.Structs.MShow.MShow+import WinDll.Structs.MShow.CSharp+import WinDll.Structs.MShow.C+import WinDll.Structs.Folds.HaskellSrcExts++import WinDll.Utils.HaddockRead++import Data.List+import Data.Char+import Data.Maybe+import Data.Generics (everywhere,mkT)+import qualified Data.Map as M++import Control.Monad++import qualified Language.Haskell.Exts as Exts+ +-- | Write out the main header file and the definition file for the exports +writeCsFiles :: Component+writeCsFiles = do inform _normal "Generating C# files for pipeline"+ modInfo <- generateMain+ session <- get+ ann <- makeSessionAnn+ doclist <- getDocumentationInfo+ let name = namespace session+ spec = (specs.pipeline) session+ natives = (n_exports.workingset) session+ datatypes = d1++d2+ functions = modFunctions modInfo+ (d1 , d2) = modDatatypes modInfo+ exports = modExports modInfo+ callbacks = modCallbacks modInfo+ callconv = call session+ defs = natives ++ manualdef+ ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon))+ 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]+ else []+ + inform _detail "Creating C# structures & function header file"+ createComponent (name++".cs") (return $ mshow $ generateCsFile exports doclist callbacks + natives 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 x = createCsType (annWorkingSetCs ann) t+ restype = swapList (last x)+ rest = case length x > 1 of+ True -> init x+ False -> []+ names = ["arg"++show n|n<-[1..(length x-1)]]+ resp = foldl (\a b->a ++ " " ++ b) "" . lines+ args = zipWith mkArg names rest+ callc = if callconv == CCall+ then "CallingConvention=CallingConvention.Cdecl"+ 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"]+ ] ++ lookupRetAttr restype+ , cseName = n+ , cseRetType = restype+ , cseArguments = args+ }+ mkArg nm ty = Argument (lookupAttr ty) ty nm+ + makeCsCallback (Callback nm t _ _ _) = let conv = if callconv == CCall+ then "CallingConvention.Cdecl"+ else "CallingConvention.StdCall"+ attr = [Attr Normal "UnmanagedFunctionPointer" [conv]]+ x = createCsType (annWorkingSetCs ann) t+ restype = last x+ rest = case length x > 1 of+ True -> init x+ False -> []+ names = ["arg"++show n|n<-[1..(length x-1)]]+ resp = foldl (\a b->a ++ " " ++ b) "" . lines+ args = zipWith mkArg names rest+ in CsCallback { cscName = nm+ , cscTopAttr = attr ++ lookupRetAttr restype+ , cscRetType = restype+ , cscArguments = args+ }+ + (enums, forwards, structs) = unzip3 (map (CG.generateCCode (lookupCs (annWorkingSetCs ann) True)) dtypes)+ in CSharp { _functions = map makeCsExport exps+ , _preserved = map (\(HaskellExport clp _ e) -> makeCsExport e) natives+ , _rtscontrol = map (\(HaskellExport clp _ e) -> makeCsExport e) defs+ , _callbacks = map makeCsCallback calls+ , _callconv = callconv+ , _header = mkHeader+ , _namespace = "WinDll.Generated"+ , _class = classname+ , _includes = map CsInclude + [LibInclude "System"+ ,LibInclude "System.Collections.Generic"+ ,LibInclude "System.Linq"+ ,LibInclude "System.Text"+ ,LibInclude "System.Runtime.InteropServices"+ ,LibInclude "WinDll"+ ,LocalInclude "Utils"+ ]+ , _structs = map upgradeField (join structs)+ , _typeDecls = []+ , _enums = map CsDataEnum (join enums)+ }+ +-- | Generate C# structs from the datatype declarations+upgradeField :: DataField -> CsStruct+upgradeField (Forward _ _) = error "Forward declarations are not needed by C#"+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"]]+ _ -> error "unsupported Kind value in c# conversion"+ styp = case kind of + Struct -> CsTStruct+ Union -> CsTUnion+ _ -> error "unsupported Kind value in c# conversion"+ mkElements (Value _ name typ (Just nm)) = let stype = name ++ mshow typ+ sattr = lookupAttr stype+ attr = case kind of+ Union -> Attr Normal "FieldOffset" ["0"] : sattr+ _ -> sattr+ in Argument attr stype nm+ mkElements x = error $ "Argument type not supported: " ++ show x + in CsStruct { cssType = styp+ , cssTopAttr = attr+ , cssName = name+ , cssElements = map mkElements args+ } +upgradeField (Field{} ) = error "Typedef field declarations are not supported"+ +-- | Lookup Attributes for struct paramaters+-- these get prefixed with 'param: ' +lookupArgAttr :: String -> [Attr]+lookupArgAttr ty = [ Attr 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 ]++-- | Perform a lookup of marshalling attributes for a type+lookupAttr :: String -> [Attr] +lookupAttr ty = if "CBF" `isPrefixOf` ty+ then [Attr Normal "MarshalAs" ["UnmanagedType.FunctionPtr"]]+ else maybe [] id (lookup ty attlist)+ +-- | List containing mapping to C# Attributes from type +attlist ::[(String , [Attr] )]+attlist = [("String" , mk "LPWStr" )+ ,("char*" , [] )+ ,("Int" , [] )+ ,("Int8" , mk "SByte" )+ ,("Int16" , mk "I2" )+ ,("Int32" , mk "I4" )+ ,("Int64" , mk "I8" )+ ,("Word8" , mk "U1" )+ ,("Word16" , mk "U2" )+ ,("Word32" , mk "U4" )+ ,("Word64" , mk "U8" )+ ,("Float" , [] )+ ,("Double" , [] )+ ,("CWString" , mk "LPWStr" )+ ,("CInt" , mk "I4" )+ ,("Bool" , mk "I1" )+ ,("FastString" , mk "LPWStr" )+ ,("FastInt" , mk "I4" )+ ,("Char" , [] )+ ,("CWchar" , [] )+ ,("CChar" , [] )+ ,("Integer" , mk "I8" )+ ,("Rational" , mk "I8" )+ ,("StablePtr" , [] )+ ,("()" , [] )]+ where mk x = [Attr Normal "MarshalAs" ["UnmanagedType." ++ x]]
+ WinDll/CodeGen/Haskell.hs view
@@ -0,0 +1,297 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Generates the needed Haskell code needed Storage instances by the FFI Calls.+--+-----------------------------------------------------------------------------++module WinDll.CodeGen.Haskell where++import WinDll.Structs.Structures hiding (Import,Pragma)+import qualified WinDll.Structs.Structures as ST+import WinDll.Structs.C+import WinDll.Structs.Haskell hiding (pragmas)+import WinDll.Structs.MShow.MShow+import WinDll.Structs.MShow.Haskell+import WinDll.Structs.Folds.Haskell +import WinDll.Utils.Pragma++import WinDll.Session+import WinDll.Builder+import WinDll.Utils.Feedback+import WinDll.Identifier+import WinDll.Parsers+import WinDll.Lib.NativeMapping+import WinDll.Lib.Instances++import System.Random+import System.FilePath+import System.IO.Unsafe++import qualified Language.Haskell.Exts as Exts++import Data.List+import Data.Char+import Data.Maybe +import Data.Generics (listify, mkT, everywhere)+import Data.Monoid++import Control.Monad++import Debug.Trace++-- | Internal function type+type Func = Name -> Bool -> DataType -> HaskellStorable+type FuncP = Name -> Bool -> DataType -> [StorablePeek]++-- | Write the main haskell file out to disc+writeHaskellFiles :: Component+writeHaskellFiles = do session <- get+ let name = namespace session+ createComponent (name++".hsc") mkHaskell+ +-- | create module name and top level declarations+mkHaskell :: Exec String+mkHaskell = do modInfo <- generateMain+ session <- get+ let name = namespace session+ deps = (dependencies.workingset) session+ natives = (n_exports.workingset) session+ spco = (specs.pipeline) session+ build = pipeline session+ fullfile = dirPath build+ odir = outputDIR session+ bdir = baseDir session+ ldir = odir ++ [pathSeparator] ++ "Includes"+ datatypes = simple_datatypes ++ spec_datatypes+ _exports = modExports modInfo+ callbacks = modCallbacks modInfo+ stables = modStablePtrs modInfo+ + (simple_datatypes, spec_datatypes) = modDatatypes modInfo+ + -- Code from pragmas+ cmds = getPragmas "IMPORT" ((pragmas.workingset) session)+ prag_imps = map Import $ concatMap (\(ST.Pragma _ x)->x) cmds+ + cmds' = getPragmas "INSTANCE" $ (pragmas.workingset) session+ args = map (\(ST.Pragma _ x)->unwords x) cmds'+ mkType' x = let (y:n:_) = words x -- TODO: this is unsafe, fix it+ ns = read n+ typenames = zipWith (flip (++).show) [1..ns] (repeat "a")+ typevars = map (\x->Exts.TyVar (Exts.Ident x)) (y:typenames)+ mkPtr x = Exts.TyApp (Exts.TyCon (Exts.UnQual $ Exts.Ident "Ptr")) (Exts.TyParen x)+ in TypeDecL (y++"Ptr") typenames $ mkPtr (foldr1 Exts.TyApp typevars)+ -- end pragma code+ + ann <- makeSessionAnn+ + let (imp,lets) = insertHeaders+ 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 "UndecidableInstances" -- is this one really needed?+ ,Pragma LANGUAGE "TypeSynonymInstances"+ ,Pragma LANGUAGE "FlexibleInstances"+ ,Pragma LANGUAGE "MultiParamTypeClasses"]+ (imp ++ map Import deps ++ prag_imps)+ lets+ [LocalInclude (name++".h")+ -- ,LocalInclude "Instances.h" -- already included in the generated H file+ ]+ (concatMap generateEnum $ unique $ simple_datatypes ++ specials)+ ( map mkType datatypes + ++ map mkType' args + ++ concatMap mkCallbackTypes callbacks)+ (map (mkExport ann (call session)) _exports ++ natives)+ (concatMap (mkImport ann (call session)) callbacks)+ (map (mkFunction ann) (modFunctions modInfo))+ ( map (generateStorageCode ann True) simple_datatypes+ ++ map (generateStorageCode ann True) specials)+ callbacks+ stables+ + return (mshowWithPath fullfile name bdir result)+ +-- | Create a simple identiy class from the given type+generateInstanceCode :: Type -> [String]+generateInstanceCode t = ["instance FFIType " ++ mshow t ++ " " ++ mshow t ++ " where"+ ," toFFI = id"+ ," fromFFI = id"+ ]+ +-- | Make a unique list of datatypes, kinda like nub except just checks the heads of the types.+-- To be used when creating the general enum for these types, which is why only the heads need to be checked, +-- since e.g. Maybe Int and Maybe String both just need the Maybe enum.+unique :: DataTypes -> DataTypes+unique = mkUnique []+ where mkUnique :: [String] -> DataTypes -> DataTypes+ mkUnique _ [] = []+ mkUnique lst (x:xs) = + case getName x `elem` lst of+ True -> mkUnique lst xs+ False -> x : mkUnique (getName x : lst) xs+ +-- | Generate type pointer declarations from datatypes+mkType :: DataType -> Ptr_Type+mkType (NewType name e t tag ) = mkType (DataType name e [t] tag)+mkType (DataType name e t tag) = TypeDecL (name ++ "Ptr") e + (case null e of+ True -> Exts.TyApp+ (Exts.TyCon (Exts.UnQual (Exts.Ident "Ptr"))) + (Exts.TyCon (Exts.UnQual (Exts.Ident name)))+ False -> Exts.TyApp + (Exts.TyCon (Exts.UnQual (Exts.Ident "Ptr")))+ (Exts.TyParen rest)+ )+ where rest = foldl1 Exts.TyApp $ Exts.TyCon (Exts.UnQual (Exts.Ident name)) : map (\a->Exts.TyVar (Exts.Ident a)) e+mkType _ = error "Unsupported call. Please call mkType only with NewType or DataType."+ +-- | Generate the export definitions+mkExport :: Ann -> CallConvention -> Export -> HaskellExport+mkExport ann cc ex = HaskellExport cc ann (ex{exName = exName ex ++"A"})+ +-- | 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)]+ where tyTo = Exts.TyFun+ newty+ (Exts.TyApp+ (Exts.TyCon (Exts.UnQual (Exts.Ident "IO")))+ (Exts.TyCon (Exts.UnQual (Exts.Ident $ name ++ "Ptr")))+ )+ tyFrom = Exts.TyFun+ (Exts.TyCon (Exts.UnQual (Exts.Ident $ name ++ "Ptr")))+ newty+ name = cbName cb+ newty = cbNewType cb+ otype = cbInputType cb+ +-- | Generates the type definitions for the callback functions. +mkCallbackTypes :: HaskellCallback -> [TypeDecL]+mkCallbackTypes cb = [TypeDecL ((cbName cb) ++ "Ptr") [] ty'+ ,TypeDecN (cbName cb) [] (cbInputType cb)]+ where ty' = (Exts.TyApp+ (Exts.TyCon (Exts.UnQual (Exts.Ident "FunPtr")))+ (cbNewType cb)+ )+ +-- | Generate a function definition+mkFunction :: Ann -> Function -> HaskellFunction+mkFunction ann' (Function name arr t ann orig) = HaskellFunction (name++"A") name t (ann `mappend` ann') orig++-- | Does semantically the same as map, only it's restricted in the sense that it'll +-- only return a list of lists as return type and have an empty element in between mappings+spaceMap :: (a -> [b]) -> [a] -> [[b]]+spaceMap _ [] = [[]]+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__)"])+ +-- | 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+generateEnum :: DataType -> [DataEnum]+generateEnum (DataType name _ t tag) = guard (length t > 1) >> return (mkEnum name t)+generateEnum (NewType name _ t tag) = [] -- mkEnum name [t]++-- | 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) + +-- | Create the Storage instances needed by Haskell's HSC PreProcessor+generateStorageCode :: Ann -> Bool -> DataType -> HaskellStorable+generateStorageCode ann esc d = generateTopLevelStruct d+ where + generateTopLevelStruct :: DataType -> HaskellStorable+ generateTopLevelStruct (NewType name e t tag) = generateTopLevelStruct (DataType name e [t] tag)+ generateTopLevelStruct (DataType name e t tag) = + let peeks = HSPeek (mkPeekHead name (isNewType d) e+ ++ rollFn mkPeek name (isNewType d) t)+ po = mkFn (mkPoke e) name (isNewType d) t+ sizes :: [(Name,Int)]+ sizes = map getSize t+ where getSize :: DataType -> (Name,Int)+ getSize (Constr name ntypes) = (name, length ntypes)+ + in HSStorable name sizes "ptr" e esc po [peeks] ann+ + isNewType (NewType _ _ _ _) = True+ isNewType (DataType _ _ [x] _) = True -- also inline datatypes with just 1 constructor+ isNewType _ = False+ + mkFn :: Func -> Name -> Bool -> [DataType] -> [HaskellStorable] + mkFn fn name newtpe constrs = map (fn name newtpe) constrs+ + rollFn :: (Int -> FuncP) -> Name -> Bool -> [DataType] -> [StorablePeek] + 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) = + let col = case newtpe of+ False -> [PokeTag dna "tag" _ptr (PokeValue enum)+ ,NewPtr _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)+ msg = "(length " ++ b ++ ")"+ size = PokeTag name (antName x++"_Size") _ptr (PokeVar 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+ 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)+ msg = "(length " ++ b ++ ")"+ size = PokeTag name (antName x++"_Size") _newptr (PokeVar 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)+ n1 = map toLower dna+ pp = (("c"++dna)++) -- (n1 ++)+ dnamod = case null e of+ True -> dna+ False -> "(" ++ dna ++ " " ++ unwords e ++ ")"++ mkPeekHead :: String -> Bool -> TypeNames -> [StorablePeek]+ mkPeekHead dna newtpe e =+ if newtpe then [] + else [PeekTag dna "ptr" _fulltype]+ where _fulltype = case (length e) > 0 of+ False -> dna+ True -> "(" ++ dna ++ " " ++ unwords e ++")"+ + mkPeek :: Int -> FuncP+ mkPeek c dna newtpe (Constr namep ntypes) =+ let col = case newtpe of+ True -> inner ++ [PeekReturn esc namep aName]+ 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 col+ where+ _ptr = "ptr"+ _newptr = "newptr"+ inner = guard (not $ null ntypes) + >> --(PeekValue "value'" dna "elt" _ptr []): namep ==> dna+ (concat (zipWith (\x (c,b)->let base = PeekValue (b ++ "'") dna (antName x) _ptr c+ size = PeekValue (b++"s") namep (antName x++"_Size") _ptr "CInt"+ in if annArrayIsList (antAnn x) then [base, size] else [base]) ntypes bName))+ translate2 = if esc then translatePartial (annWorkingSet ann) else id+ bName = [(mshowM 4 $ translate2 (antType (ntypes!!(x-1))), "a"++show x) | x <- [1..(length ntypes)]]+ aName = [(mshowM 2 $ (antType (ntypes!!(x-1))), "a"++show x, antAnn (ntypes!!(x-1))) | x <- [1..(length ntypes)]]
+ WinDll/CodeGen/Lookup.hs view
@@ -0,0 +1,146 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- This module contains the lookup functions to convert Haskell to +-- C import types +-- +----------------------------------------------------------------------------- + +module WinDll.CodeGen.Lookup where + +import WinDll.Structs.MShow.MShow +import WinDll.Structs.Structures +import WinDll.Structs.Folds.HaskellSrcExts +import WinDll.Session +import WinDll.Lib.Native + +import Data.List +import Data.Maybe +import Data.Generics (everywhere,mkT) + +import qualified Language.Haskell.Exts as Exts + +type LookupType = TypeNames -> Type -> Type + +-- | Lookup the correct C type of the given value +lookupC :: Defs -> TypeNames -> Type -> Type +lookupC clist vars = lookupType vars (\x->if "CBF" `isPrefixOf` x then "_t" else "_t*") id clist + +-- | Lookup the correct C# type of the given value +lookupCs :: (Bool -> Defs) -> Bool -> TypeNames -> Type -> Type +lookupCs cslist struct vars = lookupType vars (\x->if "CBF" `isPrefixOf` x then "" else "*") cbf (cslist struct) + where cbf x = if "CBF" `isPrefixOf` x then "IntPtr" else x + +-- | A general lookup function for types +-- . +-- NOTE: This needs to be rewritten to support Applied types in datastructures +-- . +-- e.g.: data Foo = Foo (Maybe Int) +lookupType :: TypeNames -> (String -> String) -> (String -> String) -> [(String,String)] -> Type -> Type +lookupType vars prefix test list + = let f = \x->fromMaybe (if x `elem` vars + then "void*" + else "" ++ x ++ prefix x) + (lookup (test x) list) + in everywhere (mkT (inner f)) + where + inner :: (String -> String) -> Exts.Name -> Exts.Name + inner f (Exts.Ident s) = Exts.Ident (f s) + inner f (Exts.Symbol s) = Exts.Symbol (f s) + +-- | Break up a Haskell type into it's losely coupled components, then convert them to c types. +-- . +-- When type applications are found, they're concatinated to match their specialized variants +-- . e.g. Maybe Int -> Maybe_int +genAndLookupC :: Defs -> Type -> TypeNames +genAndLookupC clist t = map lookup' (collectTypes t) + where lookup' x = case lookup x clist of + Nothing -> intercalate "," (words x) ++ (if "CBF" `isPrefixOf` x + then "_t" else "_t*") + Just x' -> x' + +-- | Lookup the C type's size in the lookup table \c_sizes\, this is needed when __stdcall is used. +lookupSize :: [(String, Int)] -> String -> Int +lookupSize c_sizes x = maybe 4 id (lookup x c_sizes) + +-- | Generate the appropriate C types from the given Haskell type +createCType :: Defs -> Type -> TypeNames +createCType clist + = foldType( const . const id + , (++) + , (\_ b -> return ("Tuple"++show (length b)++"_t*")) + , (\a -> map (\t -> if "CBF" `isPrefixOf` t then t ++ "_t" else t ++ "*") a) + , (\a b -> process a b) + , (\a ->maybe [mkRet a] (:[]) (lookup a clist)) . mshow + , (\a ->maybe [mkRet a] (:[]) (lookup a clist)) . mshow + , id -- (\a -> map (\t -> "(" ++ t ++ ")") a) -- C types can't have braces around them + , (\_ b _ -> return (mkRet $ mshow b)) + , (\a _ -> a) + ) + where stripBrace ('(':xs) = init xs + stripBrace x = x + + process a b = if "IO_t*" `elem` a -- We want to ignore IO, we assume all the functions preserve ref. transparency. in the case of FFI + then b' + else if "Ptr_t*" `elem` a -- We would want to transform the explicit Ptr type to a C pointer * + then map (++"*") b' + else a + where b' = map stripBrace b + + mkRet x = if "CBF" `isPrefixOf` x + then x ++ "_t" + else x ++ "_t*" + +-- | Convert C/C++ types to C# types +convertCType :: Defs -> TypeName -> TypeName +convertCType c2cslist n = maybe (strip n) id (lookup n c2cslist) + where strip n = if "_t" `isSuffixOf` n + then take (length n - 2) n + else if "_t*" `isSuffixOf` n + then take (length n - 3) n + else n + +-- | Some types when used in lists cannot use their managed counterparts. +-- like [String] needs to become char** in C# and not String*. Since +-- you cannot take the pointer of a managed structure. +swapList :: TypeName -> TypeName +swapList nm = maybe nm id (lookup nm swaplst) + where swaplst :: [(String , String )] + swaplst = [("String" , "char*" )] + +-- | Generate the appropriate C types from the given Haskell type +createCsType :: (Bool -> Defs) -> Type -> TypeNames +createCsType cslist + = foldType( const . const id + , (++) + , (\_ b -> return ("Tuples.Tuple"++show (length b)++"*")) + , (\a -> map ((\t -> if "CBF" `isPrefixOf` t then t ++ "" else t ++ "*") . swapList) a) + , (\a b -> process a b) -- We want to ignore IO, we assume all the functions preserve ref. transparency. in the case of FFI + , (\a ->maybe [mkRet a] (:[]) (lookup a cslist')) . mshow + , (\a ->maybe [mkRet a] (:[]) (lookup a cslist')) . mshow + , id -- (\a -> map (\t -> "(" ++ t ++ ")") a) -- The braces are irrelevant + , (\_ b _ -> return (mkRet $ mshow b)) + , (\a _ -> a) + ) + where stripBrace ('(':xs) = init xs + stripBrace x = x + + cslist' = cslist False + + process a b = if "IO*" `elem` a -- We want to ignore IO, we assume all the functions preserve ref. transparency. in the case of FFI + then b' + else if "Ptr*" `elem` a -- We would want to transform the explicit Ptr type to a C pointer * + then map (++"*") b' + else a + where b' = map stripBrace b + + mkRet x = if "CBF" `isPrefixOf` x + then x ++ "" + else x ++ "*"
+ WinDll/EntryPoint.hs view
@@ -0,0 +1,98 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- This module contains the code to generate the main entry point 'dllMain.c' +-- for the dll to be compiled. +-- +-- The file to be included is modular, where the following variables are supported +-- %callconv = the current calling convention +-- %name = the library's name +-- +-- See http:\/\/tdistler.com\/2007\/10\/05\/implementing-dllmain-in-a-linux-shared-library +-- and http:\/\/www.haskell.org\/ghc\/docs\/latest\/html\/users_guide\/ffi-ghc.html +----------------------------------------------------------------------------- + +module WinDll.EntryPoint where + +import WinDll.Session +import WinDll.Utils.Feedback +import WinDll.Builder + +import Data.Char + +import System.Directory +import System.FilePath +import Paths_Hs2lib + +writeEntryPoint :: Component +writeEntryPoint = createComponent "dllmain.c" _self + where _self :: Exec String + _self = fmap (entrypoint.workingset) get + +-- | Adjust sets the dllmain file based on the given filepath +setEntryPoint :: Exec () +setEntryPoint = + do inform _normal "Validating main file..." + session <- get + let _main = dllmain session + manual = if dllmanual session then ("no"++) else id + let file' = if null _main + then "Templates" ++ pathSeparators ++ manual ( + case (platform session) of + Windows -> "main.template-win.c" + Unix -> "main.template-unix.c") + else _main + file <- liftIO $ getDataFileName file' + exists <- liftIO $ doesFileExist file + unless exists (die $ "The supplied file '" ++ file ++ "' does not exist." ) + put $ session { dllmain = file } + +-- | Generate the required entry point and store it in the session +generateEntryPoint :: Exec () +generateEntryPoint = + do inform _normal "Discovering name for entry point..." + -- Determine the entrypoint + setEntryPoint + + session <- get + let deps = (dependencies . workingset) session + when (null deps) $ die "Dependencies are null. Please trace dependencies before calling this function" + + let name = namespace session + inform _detail ("Using '" ++ name ++ "' as main entry point.") + + inform _detail "replacing variable names in template with actual values..." + file <- liftIO $ readFile (dllmain session) + let callconv = case platform session of + Windows -> StdCall + _ -> call session + let adj = strReplace "%callconv" (map toUpper (genCcall $ callconv)) + . strReplace "%name" name + + let newfile = adj file + inform _detail ("Entrypoint:\n" ++ newfile) + + let wrkSet = (workingset session) { entrypoint = newfile } + + inform _detail "Working set updated, proceeding to next phase..." + put $ session { workingset = wrkSet } + + inform _detail "EntryPoint succesfully generated..." + +-- | A rather slow, but good enough way to replace all occurrences of a string with a string +strReplace :: String -> String -> String -> String +strReplace _ _ [] = [] +strReplace var value input@(x:xs) = + case length input < length var of + True -> input + False -> let current = take (length var) input + in if current == var + then value ++ strReplace var value (drop (length var) input) + else x : strReplace var value xs
+ WinDll/Identifier.hs view
@@ -0,0 +1,404 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- The scanner that reads the source file in via haskell-src-exts +-- and then identifies the structures that need to be converted. +-- And does priliminary scanning of these data structures. +-- +----------------------------------------------------------------------------- + +module WinDll.Identifier where + +import GHC hiding (Type,DataType,NewType,Name,getName,Module) +import GHC.Paths ( libdir ) +import DynFlags + +import Data.Char +import Data.Maybe +import Data.List +import Data.Monoid +import Data.Generics hiding (DataType) +import Data.Data hiding (DataType) +import Data.Function(on) + +import WinDll.Structs.Structures +import WinDll.Utils.Feedback +import WinDll.Utils.Types (simplify) +import WinDll.Builder +import WinDll.Parsers +import WinDll.Session +import WinDll.Lib.Native +import WinDll.Lib.Instances +import WinDll.Lib.NativeMapping + +import WinDll.Structs.MShow.MShow +import WinDll.Structs.MShow.HaskellSrcExts + +import qualified Language.Haskell.Exts.Syntax as Exts + +import Control.Arrow + +import qualified Debug.Trace as D + +-- | Generates the list of datatypes and functions needed in the merged files +generateMain :: Exec ModInfo +generateMain = + do session <- get + let cache = (mergeDep.pipeline) session + cmds = filter (\(Pragma s _)->s=="INSTANCE") $ (pragmas.workingset) session + args = map (\(Pragma _ x)->unwords x) cmds + imps = map (\(Pragma _ x)->head x) cmds + + case cache of + Just a -> return a + Nothing -> + do + let _modules = ((map fst) . modules . workingset) session + merged@(Module _ _ _ _ d f _ t) = subject args $ fixpoint (mergeModules _modules) + (simple_datatypes, spec_datatypes) = partition isSimpleData d + + (t_mods,missing,spec) = traceModules spec_datatypes imps merged + + -- liftIO $ print spec_datatypes >> print spec >> print d + -- liftIO $ print spec + -- liftIO $ print t_mods + -- liftIO $ print ( shifted simple_datatypes t_mods ) >> putStrLn "---- End ----" + -- liftIO $ print spec_datatypes + + when (not $ null missing) $ + warn ("Could not resolve the following " ++ show (length missing) ++ " type(s) which are needed: \n" ++ concatMap (\a->"\t - "++a++"\n") missing) + when (null f) $ die "No functions have been marked to be exported. There's nothing to generate. Stopping..." + + defs <- makeSessionAnn + + let mexports = exports merged ++ generateFreeExports mstableptr + mstableptr = (nubBy ((==) `on` stType) $ findStableRefs d ++ findStableRefs f ) + mcallbacks = nubBy ((==) `on` simplify . cbInputType) $ generateCallbacksFromExports defs mexports ++ concatMap (genCallbacksFromDatatype defs) d + mdep = ModInfo + (map (resolveFunctionCallbacks mcallbacks) f) -- ++ generateFreeFuncs mstableptr) + (resolveCallback False mcallbacks (shifted simple_datatypes t_mods + ,shifted spec_datatypes $ map fst spec)) + (resolveCallback True mcallbacks mexports) + mcallbacks + mstableptr + + -- liftIO $ print mdep + -- liftIO $ print mcallbacks + + put (session { pipeline = (pipeline session) { mergeDep = Just mdep + , specs = spec} }) + + return mdep + where shifted :: DataTypes -> TypeNames -> DataTypes + shifted d t = filter (\a->getName a `elem` t) d + +-- | Resolve callback types inside types if any. +-- It looks inside types and try to resolve any +-- type from the callback cache to a type synonym name. +-- e.g. (Int -> Int -> String) -> Bool to FooType -> Bool +-- The first parameter indicates if strict matching should be done +-- e.g. exact matches to types, if false parenthesis are disgarded +resolveCallback :: Data a => Bool -> [Callback] -> a -> a +resolveCallback exact cache = everywhere (mkT $ lookup cache) + where lookup :: [Callback] -> Type -> Type + lookup [] t = t + lookup ((Callback n ty ty' _ _):xs) t = + if ((==) `on` if exact then id else addParen) ty t + then Exts.TyCon (Exts.UnQual (Exts.Ident n)) + else lookup xs t + +-- | Resolve functions callbacks, then rescan them for the presence oflists +resolveFunctionCallbacks :: [Callback] -> Function -> Function +resolveFunctionCallbacks cl fn = fn' { fnAnn = ann' } + where ann' = (fnAnn fn') { annArrayIndices = findListIndices (fnType fn')} + fn' = resolveCallback True cl fn + +-- | Generates callbacks for an Export type. This hides the original type +-- b ecause if we don't, it'll generate too many specifications. +generateCallbacksFromExports :: Ann -> [Export] -> [Callback] +generateCallbacksFromExports defs xs = concatMap gen (zip xs [1..(length xs)]) + where gen :: (Export,Int) -> [Callback] + gen (exp,seed) = let cb1 = generateCallbacks defs seed (exType exp) + cb2 = generateCallbacks defs seed (exOrgType exp) + res = zipWith (\x y->update (x{cbInputType = cbOrigType y})) cb1 cb2 + update = \x-> let ty = analyzeType True (cbNewType x) + my = analyzeType False (cbOrigType x) + in x{ cbNewType = ty + , cbAnn = (cbAnn x){annArrayIndices = findListIndices ty} , cbOrigType = my} + in if length cb1 /= length cb2 + then error $ "Length mismatched, cannot generate callback types for " ++ show exp + else res + +-- | Creates the list of callbacks found in function signatures. +-- This relies on there not being unneeded parenthesis in types. e.g. +-- a -> b -> (d -> d) will incorrectly generate a callback, which is never used +generateCallbacks :: Data a => Ann -> Int -> a -> [Callback] +generateCallbacks cfg seed exports + = let types = listify isParen exports + ids = [seed..(seed + length types)] + in do (num, ty) <- zip ids types + let name = "CBF" ++ show num + newty = translatePartial (annWorkingSet cfg) ty + return $ Callback name ty newty (Exts.TyCon (Exts.Special Exts.UnitCon)) (cfg{ annArrayIndices = [], annArrayIsList = False }) + where isParen (Exts.TyParen a) = hasTyApp a + isParen _ = False + + hasTyApp = everything (||) (False `mkQ` isFun) + + isFun (Exts.TyFun{}) = True + isFun _ = False + +-- | Creates a list of callbacks from datatypes. This differs from general function +-- in that to have a higher ordered function there is no need to have a parenthesis () +-- in the type. Any abritrary function as type of one of the fields of a constructor +-- indicated a higher order function. +genCallbacksFromDatatype :: Ann -> DataType -> [Callback] +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 + +-- | Find all TyApp beginning with StablePtr and return the right sides. +findStableRefs :: (Data r, Typeable r) => r -> [Stable] +findStableRefs x = let list = listify isRef x + vals = nub $ map simplify list + dats = simplify vals + nms = map flattenToString dats + in [Stable ("free"++x) y | x <- nms, y <- dats] + where isRef (Exts.TyApp x y) + | mshowM 2 x == "StablePtr" = True + isRef _ = False + +-- | 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 + } + 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 + } + ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) + mk ty = Exts.TyFun ty ctType + +-- | Add the pragmas back into the generated AST +subject :: TypeNames -> Module -> Module +subject xs mod = mod { instances = instances mod ++ _inst + , types = types mod ++ _type + } + where _inst = map (\x->Instance ([Exts.TyCon $ Exts.UnQual $ Exts.Ident $ head $ words x])) xs + _type = map mkType xs + mkType x = let (y:n:_) = words x + ns = read n + typenames = zipWith (flip (++).show) [1..ns] (repeat "a") + typevars = map (\x->Exts.TyVar (Exts.Ident x)) (y:typenames) + mkPtr x = Exts.TyApp (Exts.TyVar (Exts.Ident "Ptr")) (Exts.TyParen x) + in TypeDecL (y++"Ptr") typenames $ mkPtr (foldr1 Exts.TyApp typevars) + +------------------------------------------------------------------------------ +-- | Fixpoint iteration to solve type synonyms. At first glance this may look +-- like it's not needed but if it's not done then incorrect C code will be +-- generated and we may not generate sufficient Haskell storable values. Look +-- at the example: +-- +-- type Foo = Data String +-- +-- data Data a = Data a +-- +-- stub :: Foo +-- stub = Data \"\" +-- +-- This would generate a warning that \"Foo\" could not be found, it would also +-- not generate the needed C code or Haskell Storable instance (specialized) to +-- Data String +-- +-- The current implementation is rather inefficient, but it's only proof of +-- concept. +-- +-- This implementation has a bug: +-- type F a = (Int,a) +-- +-- stub :: F String +-- +-- resolves to +-- +-- stub :: (Int,String) String +------------------------------------------------------------------------------ +fixpoint :: Module -> Module +fixpoint m@(Module _ _ _ e d f _ t) = + let adj' t = everywhere (mkT (make t)) + make t = case isClosed t of + True -> swapTypes (typeName t) (repTypes t) + False -> unifyType t + adl = map adj' t + m' = (apply adl m) { types = t } + changed = m/=m' + apply = flip (foldr ($)) + in if changed then fixpoint m' else m' + +------------------------------------------------------------------------------ +-- | This is a hack to get a working first version. It basically merges all +-- module declaration, which introduces various restrictions on the first +-- version of WinDll. +-- +-- Current Restrictions: +-- - Does not automatically resolve missing datatype declarations +-- using hackage. Future releases will search library code for +-- the types you need to resolve this but currently you'll +-- get a missing instance error. +-- +-- - You cannot export functions which have the same name +-- (even if they're in different modules because 1 big hsc +-- file is generated at the moment, no conflict resolutions) +-- +-- - You cannot export datatypes with the same name, same +-- restriction as above. +------------------------------------------------------------------------------ +mergeModules :: [WinDll.Structs.Structures.Module] -> WinDll.Structs.Structures.Module +mergeModules = mconcat + +-- | 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 +-- we nub often in order to mininize the sets we generate. If we don't do this on large +-- modules we'll end up consuming alot more memory, So it's a trade-off between speed and +-- size. And I choose size. +traceModules :: DataTypes -> TypeNames -> WinDll.Structs.Structures.Module -> (TypeNames,TypeNames,[(Name,Types)]) +traceModules specs types (Module (Header name _) _ _ _ datatypes functions insts _) = + let fun_s = nub $ concatMap (traceF True) functions + existing = nub $ getStorableInstances insts + datas = nub $ map topNameValue datatypes ++ types ++ existing + funcs = filter (noPrimFilter True) $ force_resolve_fixpoint fun_s datatypes + specials = let fun_s' = nub $ concatMap (traceF False) functions + funcs' = force_resolve_fixpoint fun_s' datatypes ++ concatMap resolve datatypes + typs = concatMap (splitType . fnType) functions ++ concatMap getTypes datatypes + known = knownDataInstances ++ map getName specs + filt = nub $ filter (`elem` known) funcs' + safe = filt \\ knownPointerTypes + in concat $ liftM2 selectTypePre safe typs -- $ D.trace (unlines $ map show typs) typs + in (funcs,funcs\\datas, nub specials) + +-- | Find all the storable instances inside the current Instances list, returns the names +getStorableInstances :: Instances -> TypeNames +getStorableInstances [] = [] +getStorableInstances (x:xs) = + case x of + Instance t -> map mshow t ++ getStorableInstances xs + QualifiedInstance "Storable" t -> map mshow t ++ getStorableInstances xs + _ -> getStorableInstances xs + +------------------------------------------------------------------------------ +-- | Fixpoint iteration to solve datatype dependencies as much as possible +-- Basically this tries to also look into Datatypes to find all the type +-- names needed. +-- . +-- . Example: +-- . data Foo = Bar Tuu +-- . data Tuu = V Int +-- . +-- . and stub :: Foo +-- . +-- . resolves to +-- . [Foo,Tuu,Int] +------------------------------------------------------------------------------ +force_resolve_fixpoint :: TypeNames -> DataTypes -> TypeNames +force_resolve_fixpoint datas datatypes = + let newdatas = catMaybes (map (flip find datatypes) datas) + newtypes = nub $ datas ++ concatMap resolve newdatas + in if newtypes == datas then newtypes else force_resolve_fixpoint newtypes datatypes + where find :: TypeName -> DataTypes -> Maybe DataType + find name [] = Nothing + find name (x:xs) = case x of + d@(NewType n _ _ _) | n==name -> Just d + d@(DataType n _ _ _) | n==name -> Just d + _ -> find name xs + +-- | Trace the structures needed for exporting this function +traceF :: Bool -> Function -> TypeNames +traceF full fn = scan $ collectTypes (fnType fn) -- collectTypesEx knownPointerTypes args + where scan = (filter (\a->isNotPrim full a && filterTypeVars a)) + +-- | Checks if the given type is not a primitive type +isNotPrim :: Bool -> TypeName -> Bool +isNotPrim full a = a `notElem` (knownPrimitives ++ if full then knownDataInstances else []) + +-- | Function to filter out all type variabls from a type +filterTypeVars :: TypeName -> Bool +filterTypeVars [] = False +filterTypeVars (x:_) = isUpper x + +-- | Combines isNotPrim and filterTypeVars +noPrimFilter :: Bool -> TypeName -> Bool +noPrimFilter b t = isNotPrim b t && filterTypeVars t + +-- | A function to resolve top level typenames, since these are the only ones that matter +topNameValue :: DataType -> TypeName +topNameValue = getName + +-- | Resolve the needed Abstract data types needed in order to marshal the given DataType definition +resolve :: DataType -> TypeNames -- [(Name,ExportName)] +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) + cast = (id :: Name -> TypeName) + n' = cast n + +-- | Create a list of TypeTags for used when resolving the types with GHC api. (Not used in version 1.0) +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 + where sanitize = filter (not.and.map isLower.head.collectTypes.antType) + create = \n -> TypeTag (mshow n) False undefined + + +-- | Lookup typing information using GHC API, in order to find out whether the type is a custom defined type, or a primitive type. +lookupType :: Type -> Maybe Type +lookupType _type = undefined + +-- | A list of the most frequently used types, It's much faster to do list lookup than query GHC, +-- so we first look up in this list and then make a call to GHC +knownPrimitives :: TypeNames +knownPrimitives = [ "Int" , "Integer", "Float" , "Double" , "String" , "Char" ,"Word64" + , "Int8" , "Int16" , "Int32" , "Int64" , "Word8" , "Word16" ,"Word32" + , "Int#" , "Float#" , "Double#" , "CWString" , "Bool" , "IO" , "()" + , "CInt" + ] ++ knownPointerTypes + +-- | A list of known pointer types, if we find these we should not trace their dependencies. +-- because they matter not. +knownPointerTypes :: TypeNames +knownPointerTypes = ["StablePtr", "Ptr"] + +-- | The first lookup venue to GHC is looking up based on the type classes that we've already covered by the FFI class. +-- So if the type is an instance of the following classes it's safe to ignore them. +knownClasses :: TypeNames +knownClasses = ["Storable" , "IO" , "Num" , "FFIType" ] + +-- askGHC :: [Types] -> IO [String] +-- askGHC
+ WinDll/Lib/Converter.hs view
@@ -0,0 +1,15 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- This module handles generically the convertion from and to native types+--+-----------------------------------------------------------------------------++module WinDll.Lib.Converter where
+ WinDll/Lib/Instances.hs view
@@ -0,0 +1,117 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Module containing definitions for misc instances, for commonly used +-- datatypes like Maybe, Either etc +-- +----------------------------------------------------------------------------- + +module WinDll.Lib.Instances + (module WinDll.Lib.Instances + ,module WinDll.Lib.InstancesTypes) where + +import WinDll.Lib.NativeMapping +import WinDll.Lib.InstancesTypes +import WinDll.Lib.Native +import WinDll.Structs.Structures +import WinDll.Structs.MShow.HaskellSrcExts +import WinDll.Structs.MShow.MShow +import WinDll.Parsers + +import Foreign +import Foreign.C +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils + +import Control.Monad +import Control.Monad.Instances +import Control.Arrow + +import Data.List +import Data.Maybe +import Data.Generics hiding (DataType) + +import qualified Language.Haskell.Exts as Exts + +import Debug.Trace + +-- | Constant of known instances +knownDataInstances = map fst instanceMappings + +-- | Mapping of instance names to specializeable datatypes +instanceMappings = [("Maybe" , specMaybe ) + ,("Either" , specEither) + ] -- ,("Located", specLocated)] + +-- | A mapping from Type name to Specialization function +getSpecializations :: DataTypes -> [(Name,[Exts.Type])] -> DataTypes +getSpecializations _ [] = [] -- trace (unlines $ map show list) $ +getSpecializations dyn list = nub $ getSpecialization list + where mapping = map (getName &&& id) dyn ++ instanceMappings + + getSpecialization :: [(Name,[Exts.Type])] -> DataTypes + getSpecialization [] = [] + getSpecialization ((n,t):xs) = + case lookup n mapping of + Nothing -> getSpecialization xs + Just f -> let adt = specialize t f + typ = getTypes adt + cls = concatMap (\x-> maybe [] (flip selectTypePre x) ((getHead . stripTop) x)) typ + emb = getSpecializations dyn cls + in adt : emb ++ getSpecialization xs --(map translate t) + +-- | A mapping from Type name to the simple identity types that are needed +-- Since the problem with Overlapping instances in GHC only doing head matches +-- is preventing me to solve this with general classes. +getInstances :: Defs -> [(Name,Types)] -> [Types] +getInstances _ [] = [] +getInstances defs ((n,t):xs) = + case lookup n instanceMappings of + Nothing -> getInstances defs xs + Just f -> map (translate defs) t : getInstances defs xs + +-- | Specializable constant for Maybe +specMaybe :: DataType +specMaybe = let con = [Constr "Nothing" [] + ,Constr "Just" [AnnType "maybe_just_var1" ty noAnn ty] + ] + 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] + ] + tyA = Exts.TyVar (Exts.Ident "a") + tyB = Exts.TyVar (Exts.Ident "b") + in DataType "Either" ["a","b"] con NoTag + +-- | 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] + ] + tyA = Exts.TyCon (Exts.UnQual (Exts.Ident "SrcSpan")) + tyB = Exts.TyVar (Exts.Ident "e") + in DataType "Located" ["e"] con NoTag + +-- | A function that can specialize any DataType +specialize :: [Exts.Type] -> DataType -> DataType +specialize newtypes dt@(NewType n t f g ) = + case specialize newtypes (DataType n t [f] g) of + (DataType n' t' f' g') -> NewType n' t' (head f') g' +specialize newtypes dt@(DataType n t c d) + | length t <= length newtypes = let newc = everywhere (mkT spectype) c + in DataType n (map (mshowM 2) newtypes) newc d + | otherwise = error $ "fatal error in specialization of '" ++ show n ++ "' the supplied list does not contain sufficient elements to do a specialization" + where spectype :: Type -> Type + spectype = foldr (.) id $ zipWith ($) (map swapTypes t) newtypes +
+ WinDll/Lib/InstancesTypes.hs view
@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------+-- |+-- Module : WinDll.Lib.InstancesTypes+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Module containing types and enums for misc instances, for commonly used +-- datatypes like Maybe, Either etc+--+-----------------------------------------------------------------------------++module WinDll.Lib.InstancesTypes where++import Foreign+ +maybenothing :: Int+maybenothing = 0+maybejust :: Int+maybejust = 1++eitherleft,eitherright :: Int+eitherleft = 0+eitherright = 1++type MaybePtr a = Ptr (Maybe a)+type EitherPtr a b = Ptr (Either a b)
+ WinDll/Lib/Native.hs view
@@ -0,0 +1,140 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- This module contains the lookup values to do type conversions. +-- These lists are the basic, build-in predefined lists. +-- +----------------------------------------------------------------------------- + +module WinDll.Lib.Native where + +type Defs = [(String, String)] + +-- | List containing mapping to C/C++ Types +nativeLisths2c :: [(String , String )] +nativeLisths2c = [("String" , "wchar_t*" ) + ,("Int" , "int" ) + ,("Int8" , "int8_t" ) + ,("Int16" , "int16_t" ) + ,("Int32" , "int32_t" ) + ,("Int64" , "int64_t" ) + ,("Word8" , "uint8_t" ) + ,("Word16" , "uint16_t" ) + ,("Word32" , "uint32_t" ) + ,("Word64" , "uint64_t" ) + ,("Float" , "float" ) + ,("Double" , "double" ) + ,("CWString" , "wchar_t*" ) + ,("CInt" , "int" ) + ,("Bool" , "int8_t" ) + ,("FastString" , "wchar_t*" ) + ,("FastInt" , "int" ) + ,("Char" , "wchar_t" ) + ,("CWchar" , "wchar_t" ) + ,("CChar" , "char" ) + ,("Integer" , "long long int" ) + ,("Rational" , "long long int" ) + ,("StablePtr" , "void*" ) + ,("()" , "void" )] + +-- | Contains a list of mapping types. +-- This is the first list to be extended by the pragmas +-- We need to preserve the Haskell type name for later +-- transformations and for FFI +nativeConvList :: [(String,String)] +nativeConvList = [("String" ,"CWString" ) + ,("Int" ,"CInt" ) + ,("Bool" ,"Int8" ) + ,("Float" ,"CFloat" ) + ,("FastString" ,"CWString" ) + ,("CWString" ,"CWString" ) + ,("CDouble" ,"CDouble" ) + ,("CInt" ,"CInt" ) + ,("CIntPtr" ,"CIntPtr" ) + ,("CWchar" ,"CWchar" ) + ,("CLLong" ,"CLLong" ) + ,("FastInt" ,"CInt" ) + ,("Double" ,"Double" ) + ,("Char" ,"CWchar" ) + ,("Integer" ,"CLLong" ) + ,("Rational" ,"CDouble" ) + ,("IO" ,"IO" ) + ,("()" ,"()" ) + ,("StablePtr" ,"StablePtr" ) + ,("Ptr" ,"Ptr" ) + ,("FunPtr" ,"FunPtr" )] + +-- | List of type conversion from C/C++ to C# types +nativeC2cslist :: [(String , String )] +nativeC2cslist = [("wchar_t*" , "char*" ) + ,("int" , "int" ) + ,("int8_t" , "SByte" ) + ,("int16_t" , "Int16" ) + ,("int32_t" , "Int32" ) + ,("int64_t" , "Int64" ) + ,("uint8_t" , "Byte" ) + ,("uint16_t" , "UInt16" ) + ,("uint32_t" , "UInt32" ) + ,("uint64_t" , "UInt64" ) + ,("float" , "float" ) + ,("double" , "double" ) + ,("wchar_t" , "char" ) + ,("void*" , "void*" ) + ,("void" , "void" ) + ,("long long int" , "long" )] + +-- | List containing mapping to C# Types +nativeCslist :: Bool -> [(String , String )] +nativeCslist struct = [("String" , str ) + ,("Int" , "int" ) + ,("Int8" , "SByte" ) + ,("Int16" , "Int16" ) + ,("Int32" , "Int32" ) + ,("Int64" , "Int64" ) + ,("Word8" , "Byte" ) + ,("Word16" , "UInt16" ) + ,("Word32" , "UInt32" ) + ,("Word64" , "UInt64" ) + ,("Float" , "float" ) + ,("Double" , "double" ) + ,("CWString" , str ) + ,("CInt" , "int" ) + ,("Bool" , "bool" ) + ,("FastString" , str ) + ,("FastInt" , "int" ) + ,("Char" , "char" ) + ,("CWchar" , "Char" ) + ,("CChar" , "char" ) + ,("Integer" , "long" ) + ,("Rational" , "long" ) + ,("StablePtr" , "IntPtr" ) + ,("IntPtr" , "IntPtr" ) + ,("()" , "void" )] + where str = if struct then "char*" else "String" + +-- | List containing mapping to CSizes +nativeC_sizes ::[(String , Int)] +nativeC_sizes = [("*" , 4) + ,("wchar_t" , 2) + ,("int" , 4) + ,("int8_t" , 1) + ,("int16_t" , 2) + ,("int32_t" , 4) + ,("int64_t" , 8) + ,("uint8_t" , 1) + ,("uint16_t" , 2) + ,("wchar_t" , 4) + ,("uint32_t" , 8) + ,("float" , 4) + ,("double" , 8) + ,("char" , 1) + ,("long long int" , 8) + ,("void" , 0) + ]
+ WinDll/Lib/NativeMapping.hs view
@@ -0,0 +1,384 @@+{-# 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/Tuples.hs view
@@ -0,0 +1,637 @@+{-# 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 view
@@ -0,0 +1,464 @@+{-# 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/Parsers.hs view
@@ -0,0 +1,566 @@+ {-# 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/Session.hs view
@@ -0,0 +1,248 @@+{-# 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
@@ -0,0 +1,95 @@+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- A module to convert one datatype to another isomorphic datatype. +-- +----------------------------------------------------------------------------- + +module WinDll.Shared.Remapper where + +import Data.Data hiding (DataType) +import Data.Typeable +import Data.Generics hiding (DataType) + +import Foreign + +import WinDll.Lib.NativeMapping +import WinDll.Structs.Structures + +-- | Get the number of fields of a constructor +nrArgs :: Data a => a -> Int +nrArgs = gmapQr (+) 0 (const 1) + +-- | Convert at runtime back and forth between *simple* data structures. (Enums only). For more complex types the compiler generates the structures. This is usefull for when the preprocessor does not have the source readily available +isoConvert :: (Data a, Data b) => a -> b +isoConvert a = let conDest i = indexConstr (dataTypeOf result) i + constIndex = constrRep $ toConstr a + result = case constIndex of + (AlgConstr i) -> fromConstr (conDest i) + rest -> fromConstr (repConstr (dataTypeOf result) rest) + in result + +-- | Class to manage the convertions that the parser generates +class FFIType a b => IsoConvert a b where + convertTo :: a -> b + convertFrom :: b -> a + +-- | Same types are always convertable to eachother, because they implement FFITypes +instance Num a => IsoConvert a a where + convertTo = id + convertFrom = id + +-- | Boolean types can also be converted, yay +instance IsoConvert Bool Bool where + convertTo = id + convertFrom = id + +-- | Creating of pointer type should also always be possible (this instance is redundant, FFITypes also provides this conversion, however, since we'll use IsoConvert for all type conversions, this instances simplifies things) +instance Storable a => IsoConvert a (Ptr a) where + convertTo = toFFI + convertFrom = fromFFI + +-- data DataType = DataType Name [Type] [DataType] + -- | NewType Name [Type] DataType + -- | Constr Name [Type] + +-- | generate the isomorphic convertion from and between the two type given and the associated FFI type +createDataTypeIsoMorphism :: DataType -> String +createDataTypeIsoMorphism d@(DataType name types consts tag) = unlines $ (genInstance d) : (createFromDataIsoConvert name types consts) : [] +createDataTypeIsoMorphism d@(NewType name types cons tag ) = unlines $ (genInstance d) : (createFromDataIsoConvert name types [cons]) : [] +createDataTypeIsoMorphism (Constr name typevars ) = [] + +-- | Create the from Convertion function +createFromDataIsoConvert :: Name -> Types -> DataTypes -> String +createFromDataIsoConvert name types datatypes = [] + +-- | Generate the instance declaration +genInstance :: DataType -> String +genInstance (DataType name types _ _) = internalGenInstance name types +genInstance (NewType name types _ _ ) = internalGenInstance name types +genInstance (Constr _ _ ) = error "Called GenInstance on a constructor" + +internalGenInstance :: Name -> [Type] -> String +internalGenInstance name types = + unlines $ + (case null types of + True -> "instance IsoConvert " ++ name ++ " T" ++ name ++ " where" + False -> "instance FFYType " ++ listTypesUsing " " types ++ " => IsoConvert (" ++ name ++ " " ++ listTypesUsing " " types ++ ") (T" ++ name ++ " " ++ listTypesUsing " " types ++ ") where") + : [" convertTo = toT" ++ name," convertFrom = fromT" ++ name] + +-- | Converts a list of Types to a string to be printed to file. +listTypesUsing :: String -> [Type] -> String +listTypesUsing _ [] = [] +listTypesUsing f types = foldl1 (\a b->a++f++b) types
+ WinDll/Structs/C.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Structures used when generating C code in WinDll+--+-----------------------------------------------------------------------------++module WinDll.Structs.C where++import qualified Language.Haskell.Exts as Exts+import qualified Language.Haskell.Exts.SrcLoc as Span++import Data.Data++import WinDll.Structs.Structures+import WinDll.Session (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+ | LocalInclude Name -- ^ @LocalInclude@ These includes are to be included from a local path+ deriving (Eq,Show,Data,Typeable)++-- | This structure hold the enum information which represent the data constructors that are need to be exported+-- This is because the following structures:+--+-- data Foo = Foo+-- | Bar+--+-- will create a a union containing 2 structs Foo and Bar, but we need to know which one+-- of the constructors was used, and for that we use the enum.+--+-- enum FooSelector {cFooFoo, cFooBar}+data DataEnum = DataEnum Name [String] -- ^ @DataEnum@ The information here denotes the enum name the enum elements.+ deriving (Eq,Show,Data,Typeable)+ +-- | This type determines whether the DataField is a Struct or Union.+data CDataType = Struct -- ^ @Struct@ A C Struct+ | Union -- ^ @Union@ A C Union+ | ENum -- ^ @Enum@ A C Enum+ | VAlue -- ^@Value@ A normal C value+ deriving (Eq,Show,Data,Typeable)+ +-- | Determines whether the FieldValue to be printed is of a normal or a Pointer type+data FieldType = Normal -- ^ @Normal@ A normal C value+ | Pointer -- ^ @Pointer@ A C pointer reference+ deriving (Eq,Show,Data,Typeable) + +-- | Determines whether the DataField to be printed is of a normal or a typedef type+data DataFieldType = TypeDef -- ^ @TypeDef@ A typedef C value+ | NormalDef -- ^ @NormalDef@ A C normal value+ deriving (Eq,Show,Data,Typeable)+ +-- | This type holds both structs and unions as they have the same general outline, just different names.+-- It's a good idea to keep them in one structure as to make the depencency graph tracing easier later on.+data DataField = Field DataFieldType CDataType Name TypeName [DataField] -- ^ @Field@ This decribes which instance to created+ | Value CDataType TypeName FieldType (Maybe Name) -- ^ @Value@ This describes the elements of the Field above. + | Forward CDataType Name -- ^ @Forward@ Forward references.+ -- Though you could use it to make nested structures, This is not used+ -- Inside WinDll. + deriving (Eq,Show,Data,Typeable)+ +-- | This is the head structure to hold and describe the entire C file to be generated. Generating the instances from+-- This type should be rather easy. +data C = C { c_includes :: [Include] -- ^ @Includes@ The includes to be generated in the file+ , c_callconv :: CallConvention -- ^ The calling convention used for the file+ , c_callbacks :: [Callback] -- ^ @callbacks@ The list of C callback functions to generate+ , c_enums :: [DataEnum] -- ^ @Enums@ The file enums in the c file+ , c_forwards :: [DataField] -- ^ The forward references needed in the c file+ , c_fields :: [DataField] -- ^ The Actual fields in the C file.+ } + deriving (Eq,Show,Data,Typeable)
+ WinDll/Structs/CSharp.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Structures used when generating CSharp code in WinDll+--+-----------------------------------------------------------------------------++module WinDll.Structs.CSharp where++import qualified Language.Haskell.Exts as Exts+import qualified Language.Haskell.Exts.SrcLoc as Span++import Data.Data++import WinDll.Session++import WinDll.Structs.Structures+import WinDll.Structs.Types+import WinDll.Structs.C+import WinDll.Structs.MShow.C+import WinDll.Structs.Folds.C++type Key = String+type Value = String+type Values = [Value]+type Comment = String+type CsType = String++-- | Datatype to hold the attributes for the generated C\# types+-- The boolean indicates whether the Attribute is a parameter+-- attribute.+data Attr = Attr AttrType Key Values + deriving(Eq,Data,Typeable)+ +-- | The type of the attribute annotation+-- normal means no annotation+-- param means 'param: '+-- return means 'return: '+data AttrType = Normal | Param | Return+ deriving(Eq,Data,Typeable)+ +-- | The type of an argument of a function+data Argument = Argument [Attr] CsType Name+ deriving(Eq,Data,Typeable)++-- | Module export declarations.+data CsExport + = CsExport { cseComments :: [Comment]+ , cseTopAttr :: [Attr]+ , cseName :: Name+ , cseRetType :: CsType+ , cseArguments :: [Argument]+ }+ deriving(Eq,Data,Typeable)++-- | The type of the struct. Determins how it's printed.+data CsStructType = CsTUnion | CsTStruct+ deriving(Eq,Data,Typeable)+ +-- | Newtype wrapper for the C# include+newtype CsInclude = CsInclude { csUnpackInclude :: Include }+ deriving(Eq,Data,Typeable) + +-- | Newtype wrapper for the C# Callbacks+data CsCallback = CsCallback { cscName :: Name+ , cscTopAttr :: [Attr]+ , cscRetType :: CsType+ , cscArguments :: [Argument]+ }+ deriving(Eq,Data,Typeable) + +-- | Newtype wrapper for the C# include+newtype CsDataEnum = CsDataEnum { csUnpackEnum :: DataEnum }+ deriving(Eq,Data,Typeable)++-- | Declaration for a C# struct+data CsStruct+ = CsStruct { cssType :: CsStructType+ , cssTopAttr :: [Attr]+ , cssName :: Name+ , cssElements :: [Argument]+ }+ deriving(Eq,Data,Typeable)++-- | The main C# file+data CSharp + = CSharp { _header :: String+ , _namespace :: String+ , _class :: String+ , _callconv :: CallConvention+ , _callbacks :: [CsCallback]+ , _includes :: [CsInclude]+ , _typeDecls :: [TypeDecL]+ , _functions :: [CsExport]+ , _preserved :: [CsExport]+ , _rtscontrol :: [CsExport]+ , _structs :: [CsStruct]+ , _enums :: [CsDataEnum]+ } + deriving(Eq,Data,Typeable)+
+ WinDll/Structs/Folds/C.hs view
@@ -0,0 +1,100 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- General Folds for the Haskell-Src-Exts datatypes+--+-----------------------------------------------------------------------------+module WinDll.Structs.Folds.C where++import WinDll.Structs.C+import WinDll.Structs.Types+import WinDll.Structs.Structures(Callback)+import WinDll.Session(CallConvention)++-- * Type Algebras for the current ADTs in the C file++-- | Type Algebra for the Include ADT+type IncludeAlgebra a = (Name -> a+ ,Name -> a+ )++-- | Type Algebra for the DataEnum ADT +type DataEnumAlgebra a = (Name -> [String] -> a)++-- | Type Algebra for the CDataType ADT+type CDataTypeAlgebra a = (a+ ,a+ ,a+ ,a+ )+ +-- | Type Algebra for the FieldType ADT+type FieldTypeAlgebra a =(a+ ,a+ )+ +-- | Type Algebra for the DataFieldType ADT+type DataFieldTypeAlgebra a =(a+ ,a+ )+ +-- | Type Algebra for the DataField ADT+type DataFieldAlgebra a = (DataFieldType -> CDataType -> Name -> TypeName -> [a] -> a+ ,CDataType -> TypeName -> FieldType -> (Maybe Name) -> a+ ,CDataType -> Name -> a+ )+ +-- | Type Algebra for the C ADT +type CAlgebra a = ([Include] -> CallConvention -> [Callback] -> [DataEnum] -> [DataField] -> [DataField] -> a)++-- * The general folds used with the ADTs defined in the C file++-- | General fold for the Include ADT+foldInclude :: IncludeAlgebra a -> Include -> a+foldInclude (lib,local) = fold+ where fold (LibInclude a) = lib a+ fold (LocalInclude a) = local a++-- | General fold for the DataEnum ADT +foldDataEnum :: DataEnumAlgebra a -> DataEnum -> a+foldDataEnum (dataenum) = fold+ where fold (DataEnum a b) = dataenum a b+ +-- | General fold for the CDataType ADT+foldCDataType :: CDataTypeAlgebra a -> CDataType -> a+foldCDataType (struct,union,dnum,val) = fold+ where fold Struct = struct+ fold Union = union+ fold ENum = dnum+ fold VAlue = val+ +-- | General fold for the FieldType ADT+foldFieldType :: FieldTypeAlgebra a -> FieldType -> a+foldFieldType (normal,pointer) = fold+ where fold Normal = normal+ fold Pointer = pointer + +-- | General fold for the DataFieldType ADT+foldDataFieldType :: DataFieldTypeAlgebra a -> DataFieldType -> a+foldDataFieldType (typedef,normaldef) = fold+ where fold TypeDef = typedef+ fold NormalDef = normaldef+ +-- | General fold for the DataField ADT+foldDataField :: DataFieldAlgebra a -> DataField -> a+foldDataField (field,value,forw) = fold+ where fold (Field x a b c d) = field x a b c (map fold d)+ fold (Value a b c d) = value a b c d+ fold (Forward a b) = a `forw` b+ +-- | General fold for the C ADT+foldC :: CAlgebra a -> C -> a+foldC (ccons) = fold+ where fold (C a b c d e f) = ccons a b c d e f
+ WinDll/Structs/Folds/CSharp.hs view
@@ -0,0 +1,69 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- General Folds for the CSharp datatypes+--+-----------------------------------------------------------------------------+module WinDll.Structs.Folds.CSharp + (module WinDll.Structs.Folds.CSharp) where++import WinDll.Structs.CSharp+import WinDll.Structs.C+import WinDll.Structs.Structures+import WinDll.Structs.Types+import WinDll.Session++-- import WinDll.Structs.Folds.C hiding (foldDataEnum)++-- * Type Algebras for the current ADTs in the C# file++-- | Type Algebra for the CAttr ADT +type AttrAlgebra a = (AttrType -> Key -> Values -> a)++-- | Type Algebra for Argument ADT+type ArgumentAlgebra a = ([Attr] -> CsType -> Name -> a)++-- | Type Algebra for Exporting of functions+type CsExportAlgebra a = ([Comment] -> [Attr] -> Name -> CsType -> [Argument] -> a)++-- | Type Algebra for C# structures+type CsStructAlgebra a = (CsStructType -> [Attr] -> Name -> [Argument] -> a)++-- | Type Algebra for the C# ADT +type CSharpAlgebra a = (String -> String -> String -> CallConvention -> + [CsCallback] -> [CsInclude] -> [TypeDecL] -> [CsExport] ->+ [CsExport] -> [CsExport] -> [CsStruct] -> [CsDataEnum] -> a)++-- * The general folds used with the ADTs defined in the C file+ +-- | General fold for the Attr ADT+foldAttr :: AttrAlgebra a -> Attr -> a+foldAttr attr = fold+ where fold (Attr b k v) = attr b k v+ +-- | General fold for the Argument ADT+foldArgument :: ArgumentAlgebra a -> Argument -> a+foldArgument arg = fold+ where fold (Argument a c n) = arg a c n+ +-- | General fold for the CsExport ADT+foldCsExport :: CsExportAlgebra a -> CsExport -> a+foldCsExport csexport = fold+ where fold (CsExport c t n r a) = csexport c t n r a++-- | General fold for the CsStruct ADT+foldCsStruct :: CsStructAlgebra a -> CsStruct -> a+foldCsStruct csstruct = fold+ where fold (CsStruct ty to n e) = csstruct ty to n e++-- | General fold for the CSharp ADT+foldCSharp :: CSharpAlgebra a -> CSharp -> a+foldCSharp csalg = fold+ where fold (CSharp a b c d e f g h i j k l) = csalg a b c d e f g h i j k l
+ WinDll/Structs/Folds/Haskell.hs view
@@ -0,0 +1,68 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- General Folds for the Haskell datatypes that are big enough+-- to warrant one.+--+-----------------------------------------------------------------------------+module WinDll.Structs.Folds.Haskell where++import WinDll.Structs.Haskell+import WinDll.Structs.C+import WinDll.Structs.Types++-- * General type algebras++-- | Type Algebra for the HaskellStorable ADT+type HaskellStorableAlgebra a = ((Name -> [(Name,Int)] -> PtrName -> [TypeName] -> Bool -> [a] -> [a] -> Ann -> a)+ ,(Name -> Int -> [StorablePoke] -> a)+ ,([StorablePeek] -> a)+ )+ +-- | Type Algebra for the StorablePeek ADT +type StorablePeekAlgebra a = ((TypeName -> PtrName -> TypeName -> a)+ ,(Int -> [a] -> a)+ ,(Name -> TypeName -> Name -> PtrName -> TypeName -> a)+ ,(Bool -> Name -> [(Name,TypeName,Ann)] -> a)+ )+ +-- | Type Algebra for the StorablePoke ADT +type StorablePokeAlgebra a = ((TypeName -> Field -> PtrName -> a -> a)+ ,(Name -> TypeName -> a)+ ,(Name -> a)+ ,(Bool -> Name -> Maybe Name -> Type -> Ann -> a)+ , a+ )+ +-- * General folds for the algebras above++-- | General fold for the HaskellStorable ADT+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 (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+ +-- | 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
+ WinDll/Structs/Folds/HaskellSrcExts.hs view
@@ -0,0 +1,78 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- General Folds for the Haskell-Src-Exts datatypes+--+-----------------------------------------------------------------------------+module WinDll.Structs.Folds.HaskellSrcExts where++import qualified Language.Haskell.Exts as Exts+import qualified Language.Haskell.Exts.SrcLoc as Span+import Language.Haskell.Exts.Pretty++-- * General folds++-- | Fold algebra for the Type ADT in Language.Haskell.Exts.Syntax+type TypeAlgebra a = ((Maybe [Exts.TyVarBind]) -> Exts.Context -> a -> a+ ,a -> a -> a+ ,Exts.Boxed -> [a] -> a+ ,a -> a+ ,a -> a -> a+ ,Exts.Name -> a+ ,Exts.QName -> a+ ,a -> a+ ,a -> Exts.QName -> a -> a+ ,a -> Exts.Kind -> a+ )+ +-- | Fold function for the above algebra +foldType :: TypeAlgebra a -> Exts.Type -> a+foldType (tforall, tfun, ttuple, tlist, tapp+ ,tvar, tcon, tparen, tinfix, tkind) = fold+ where fold (Exts.TyForall a b c) = tforall a b (fold c)+ fold (Exts.TyFun a b) = (fold a) `tfun` (fold b)+ fold (Exts.TyTuple a b) = a `ttuple` (map fold b)+ fold (Exts.TyList a) = tlist (fold a)+ fold (Exts.TyApp a b) = (fold a) `tapp` (fold b)+ fold (Exts.TyVar a) = tvar a+ fold (Exts.TyCon a) = tcon a+ fold (Exts.TyParen a) = tparen (fold a)+ fold (Exts.TyInfix a b c) = tinfix (fold a) b (fold c)+ fold (Exts.TyKind a b) = tkind (fold a) b + +-- | Fold algebra for the Type ADT in Language.Haskell.Exts.Syntax+type TypeAlgebraIO a = ((Maybe [Exts.TyVarBind]) -> Exts.Context -> a -> a+ ,a -> a -> a+ ,Exts.Boxed -> [a] -> a+ ,a -> a+ ,Bool -> a -> a -> a+ ,Exts.Name -> a+ ,Exts.QName -> a+ ,a -> a+ ,a -> Exts.QName -> a -> a+ ,a -> Exts.Kind -> a+ )+ +-- | Fold function for the above algebra, Except in the case of a TyApp+-- The function is applied to the second argument only if the first is a "IO",+-- The boolean indicates if this is an IO application yes or no.+foldTypeIO :: TypeAlgebraIO a -> Exts.Type -> a+foldTypeIO (tforall, tfun, ttuple, tlist, tapp+ ,tvar, tcon, tparen, tinfix, tkind) = fold+ where fold (Exts.TyForall a b c) = tforall a b (fold c)+ fold (Exts.TyFun a b) = (fold a) `tfun` (fold b)+ fold (Exts.TyTuple a b) = a `ttuple` (map fold b)+ fold (Exts.TyList a) = tlist (fold a)+ fold (Exts.TyApp a b) = tapp (prettyPrint a == "IO") (fold a) (fold b)+ fold (Exts.TyVar a) = tvar a+ fold (Exts.TyCon a) = tcon a+ fold (Exts.TyParen a) = tparen (fold a)+ fold (Exts.TyInfix a b c) = tinfix (fold a) b (fold c)+ fold (Exts.TyKind a b) = tkind (fold a) b
+ WinDll/Structs/Haskell.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Structures used when generating Haskell code in WinDll+--+-----------------------------------------------------------------------------++module WinDll.Structs.Haskell+ (module WinDll.Structs.Haskell+ ,S.HaskellExport(..)+ ,S.HaskellImport(..)) where++import qualified Language.Haskell.Exts as Exts+import qualified Language.Haskell.Exts.SrcLoc as Span++import Data.Data++import WinDll.Structs.Structures hiding (Import)+import WinDll.Structs.C+import WinDll.Session+import qualified WinDll.Session as S++type Field = String+type PtrName = String++-- | Global Comments added to the top of the module+data HaskellComment = HaskellComment String+ deriving(Eq,Show,Data,Typeable)+ +-- | The type of pragma to use+data PragmaType = GHC_OPTION+ | LANGUAGE+ deriving(Eq,Show,Data,Typeable)+ +-- | GHC Pragmas to insert into the generated file+data GHCPragma = Pragma PragmaType String+ deriving(Eq,Show,Data,Typeable)++-- | Haskell Import statements+data Import = Import String+ deriving(Eq,Show,Data,Typeable)+ +-- | An hsc Let statement+data HSC_Let = HSC_Let String+ deriving(Eq,Show,Data,Typeable)+ +-- | Type declarations to pointers+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+ }+ deriving(Eq,Show,Data,Typeable)+ +-- | Simple type alias for \Callback\+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+ }+ | HSPoke { pokename :: Name -- ^ @pokename@ The name of the Constructor we're generating instances for+ , pokearrity :: Int -- ^ @pokearrity@ The arrity of the current constructor+ , pokebody :: [StorablePoke] -- ^ @pokebody@ The body of the poke+ }+ | HSPeek { peekbody :: [StorablePeek] -- ^ @peekbody@ The complete peek body+ }+ deriving(Eq,Show,Data,Typeable)+ +-- | Structure to describe the Peek values in a Storable instance+data StorablePeek = PeekTag TypeName PtrName TypeName+ | PeekEntry Int [StorablePeek]+ | PeekValue Name TypeName Name PtrName TypeName+ | PeekReturn Bool Name [(Name,TypeName,Ann)]+ 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+ | PokeValue Name+ | PokeVar Bool Name (Maybe Name) Type Ann+ | PokeReturn+ deriving(Eq,Show,Data,Typeable)+ +-- | Information about the Haskell file to generate+data HaskellFile = HaskellFile + {_hsname :: Name -- ^ @hsname@ Name of the module + , comments :: [HaskellComment] -- ^ @comments@ The top level comments to include for the module+ , pragmas :: [GHCPragma] -- ^ @pragmas@ The pragmas to include in the module+ , imports :: [Import] -- ^ @imports@ The set of imports to use in the module+ , hsclets :: [HSC_Let] -- ^ @hsclets@ The set of Hsc2Hs custom macros to include+ , includes :: [Include] -- ^ @includes@ The set of includes to include for hsc2hs to be able to calculate alignments etc+ , hsenums :: [DataEnum] -- ^ @hsenums@ Haskell Enums, used for the same purpose as in "DataEnum" in the C module.+ , hstypes :: [Ptr_Type] -- ^ @hstypes@ The Ptr type declarations used for clarity+ , hsexports :: [HaskellExport] -- ^ @hsexports@ The set of exported functions+ , hsimports :: [HaskellImport] -- ^ @hsimports@ The set of imported functions+ , hsfuncs :: [HaskellFunction] -- ^ @hsfuncs@ the set of haskell function bodies exported+ , hsstorable :: [HaskellStorable] -- ^ @hsstorable@ The set of Storable instances to create+ , hscallbacks :: [HaskellCallback] -- ^ @hscallbacks@ A set of callback functions for which mappings need to generated.+ , hsstables :: [Stable] -- ^ @hsstable@ List of stable ptrs which needs to be freed+ }+ deriving(Eq,Show,Data,Typeable)+
+ WinDll/Structs/MShow/Alignment.hs view
@@ -0,0 +1,84 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- A helper module to use hsc2hs to resolve the proper sizes for the structures+-- By examening them on a by structure bases and getting the biggest structure out of it+-- and then adding the base structure. This because most types are expressed as unions+-- and thus require some extra memory to be allocated, now because GHC doesn't use the+-- value given to the sizeOf method, I can't accurately calculate the needed space for+-- any one particular call which leaves me with the only option of allocating enough+-- space everytime to keep the biggest structure in memory.+-----------------------------------------------------------------------------++module WinDll.Structs.MShow.Alignment (resolveAlignment) where++import System.IO+import System.IO.Unsafe+import System.Directory+import System.Process+import System.FilePath++import Control.Monad++import Data.List++import System.IO+import System.IO.Error+import Paths_Hs2lib++import qualified Debug.Trace as D++-- | Resolve the alignments by creating a temp hsc file to calculate the alignments+-- then clean them up. Because this call is not in the global local state (it's called from+-- inside MShow afterall, which isn't a monad) It will not be affected by the -T flag (keep temp file)+-- . +-- It will just always delete it's temporary files immediately.+resolveAlignment :: String -> String -> String -> String -> [(String,Int)] -> Int+resolveAlignment path nspace ldir _name list = + let full = _name : map fst list+ hsc = createHSC nspace full+ (a:x:xs) = executeHSC path ldir _name hsc+ size = x + foldl' max 0 xs+ in case size `mod` a of+ 0 -> size+ _ -> size + (a - (size `mod` a))++-- | Create the actual HSC file with+createHSC :: String -> [String] -> String+createHSC name = \env -> ((("#include \""++name++".h\"\n")++) + . unlines + . ("#let alignment t = \"(%lu)\", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)":)+ . (("#alignment " ++ head env ++ "_t"):) + . map (\x->"#size "++x++"_t")) env++-- | Write the HSC file to disc, execute hsc2hs and read the value back in. This will be wrapped with+-- unsafeperform IO because again MShow is not a monad (perhaps it should be)+executeHSC :: String -> String -> String -> String -> [Int]+executeHSC path ldir name content = unsafePerformIO $ + do -- tempfile <- getTemporaryDirectory+ let infile = name ++ ".in-align.hsc"+ outfile = name ++ ".in-align.hs"+ + ldir2 <- getDataFileName "Includes" + writeFile (path ++ infile) content+ handle <- runProcess "hsc2hs" [infile+ , "-I" ++ addTrailingPathSeparator ldir ++ "Includes"+ , "-I" ++ ldir2] (Just path) Nothing Nothing Nothing Nothing+ exitcode <- waitForProcess handle+ result <- liftM (map (fst . head . (readParen True reads :: String -> [(Int, String)])) . filter inline . lines) (readFile $ path ++ outfile)+ + removeFile (path ++ infile)+ -- removeFile (path ++ outfile) -- fix the stupid locking IO+ + return result+ + where inline ('(':_) = True+ inline _ = False+
+ WinDll/Structs/MShow/C.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- MShow instances for the C datatypes+--+-----------------------------------------------------------------------------+module WinDll.Structs.MShow.C(inline') where++import WinDll.Structs.MShow.MShow+import WinDll.Structs.Folds.C+import WinDll.Structs.C+import WinDll.Structs.Types+import WinDll.Structs.Structures(Callback(..))++import WinDll.Session(genCcall)++import WinDll.CodeGen.Lookup+import WinDll.Lib.NativeMapping++import Data.Char+import Data.List++import qualified Language.Haskell.Exts as Exts++instance MShow Include where+ mshow = foldInclude ((\a->"#include <"++a++">")+ ,(\a->"#include \""++a++"\"")+ )+ +instance MShow DataEnum where+ mshow = foldDataEnum ((\a b->let fix = foldr1 (\a b->a++", "++b) . map (("c"++a)++)+ in "enum List"++a++" {" ++ fix b ++ "};"))+ +instance MShow CDataType where+ mshow = foldCDataType ("struct"+ ,"union"+ ,"enum"+ ,""+ )+ +instance MShow FieldType where+ mshow = foldFieldType ("","*")+ +instance MShow DataFieldType where+ mshow = foldDataFieldType ("typedef "+ ,""+ )+ +instance MShow DataField where+ mshow = foldDataField ((\a b c d e->unlines $ (mshow a ++ mshow b ++ " " ++ mshow c ++ " {" ):((map (indent.mshow) e) ++ ["} " ++ mshow d ++ ";"]))+ ,(\a b c d ->mshow a ++ " " ++ mshow b ++ mshow c ++ " " ++ mshow d ++";")+ ,(\a b ->"typedef " ++ mshow a++ " " ++ mshow b++ " " ++ mshow b ++ "_t;")+ )+ +instance MShow C where+ mshow = foldC ((\a cc cb b c d->unlines+ $ concat [map mshow a+ ,[]+ ,map mshow b + ,[]+ ,map mshow c + ,[]+ ,callback_decls cb cc+ ,[] + ,map mshow d]))+ -- declare callback function pointers+ where callback_decls callbacks callconv+ = let ccl = "__" ++ map toLower (genCcall callconv)+ decls = unlines $ concatMap (\(Callback n t ty _oty ann) -> + -- let x = createCType $ strip ty+ let x = createCType (annWorkingSetC ann) $ strip (translatePrimitive (annWorkingSet ann) t)+ strip p = case p of+ Exts.TyParen s -> strip s+ _ -> p+ restype = last x+ rest = case length x > 1 of+ True -> init x+ False -> [" void "]+ args = intercalate ", " rest+ in ["// type " ++ n ++ " = " ++ mshowM 2 (strip t)+ ,"typedef " ++ ccl ++ " " ++ restype ++ " (*" ++ n ++ "_t)(" ++ args ++ ");"]) callbacks + in if null callbacks+ then [] + else ["", "// Callback functions typedefs", decls]+-- | Inline a DataField definition by removing one layer of wrapping from it. +inline' :: DataField -> [DataField]+inline' (Field _ _ _ _ x) = x+inline' _ = []
+ WinDll/Structs/MShow/CSharp.hs view
@@ -0,0 +1,123 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- MShow instances for the CSharp datatypes+--+-----------------------------------------------------------------------------+module WinDll.Structs.MShow.CSharp where++import WinDll.Structs.MShow.MShow+import WinDll.Structs.Folds.CSharp+import WinDll.Structs.Folds.C+import WinDll.Structs.CSharp+import WinDll.Structs.C hiding (Normal)+import WinDll.Structs.Structures++import Data.Char+import Data.List++instance MShow CsInclude where+ mshow = foldInclude ((\a->"using "++a++";")+ ,(\a->"using WinDll."++a++";")+ ) . csUnpackInclude+ +instance MShow CsDataEnum where+ mshow = foldDataEnum ((\a b->let fix = foldr1 (\a b->a++", "++b) . map (("c"++a)++)+ in "public enum List"++a++" {" ++ fix b ++ "};")) . csUnpackEnum+ +instance MShow Attr where+ mshow = foldAttr (\p k v -> let pre = case p of+ Normal -> ""+ Param -> "param: "+ Return -> "return: "+ in pre ++ k ++ "(" ++ intercalate "," v ++ ")" )+ +instance MShow Argument where+ mshow = mshowM 1+ mshowM 1 = foldArgument (\t ty nm -> let at = "public " ++ ty ++ " " ++ nm ++ ";"+ in if null t then at else unlines $ map (\x-> "[" ++ mshow x ++"]") t ++ [at])+ mshowM 2 = foldArgument (\t ty nm -> let at = ty ++ " " ++ nm + in if null t then at else concat $ ["[" ++ intercalate ", " (map mshow t) ++ "]", at])+ +instance MShow CsExport where+ mshow = foldCsExport (\c t n r a-> let comments_body = zipWith ($) (repeat ("/// "++)) c+ params_decl = map (\(Argument _ _ n) -> "/// <param name=\"" ++ n ++ "\"></param>") a+ result_decl = if r == "void" then [] else ["/// <returns> </returns>"]+ comments = ("/// <summary>" : comments_body)+ ++ ("/// </summary>" : params_decl)+ ++ result_decl + attributes = if null t then [] else map (\x-> "[" ++ mshow x ++"]") t+ arguments = "(" ++ intercalate ", " (map (mshowM 2) a) ++ ")"+ decl = if '*' `elem` arguments || '*' `elem` r+ then "public unsafe static extern " + else "public static extern " + in unlines $ comments ++ attributes ++ [decl ++ r ++ " " ++ n ++ arguments ++ ";",""])+ +instance MShow CsStruct where+ mshow cs = let attr = map (\x-> "[" ++ mshow x ++"]") (cssTopAttr cs) + indent' x = " " ++ x+ args = concatMap (map indent'.lines.mshow) (cssElements cs)+ in unlines $ attr +++ ["public unsafe struct " ++ cssName cs+ ,"{"+ ] ++ args +++ ["};"+ ,""+ ]+ +instance MShow CsCallback where+ mshow cs = let attr = map (\x-> "[" ++ mshow x ++"]") (cscTopAttr cs) + indent' x = " " ++ x+ args = intercalate "," (map (mshowM 2) (cscArguments cs))+ ret = cscRetType cs+ unsafe = if '*' `elem` args || '*' `elem` ret then "unsafe " else ""+ in unlines $ attr ++ ["public " ++ unsafe ++ "delegate " ++ ret ++ " " ++ (cscName cs) ++ "(" ++ args ++ ");"]++instance MShow CSharp where+ mshow cs = let nm = "namespace " ++ _namespace cs+ indent = (" " ++)+ csexp = concatMap (map indent.lines.mshow) $ _functions cs+ cspre = let cs' = _preserved cs+ val = (indent "/// Preserved export statements") : (concatMap (map indent.lines.mshow) cs')+ in if null cs' then [] else val+ csrts = let cs' = _rtscontrol cs+ val = (indent "/// Runtime control methods") : (concatMap (map indent.lines.mshow) cs')+ in if null cs' then [] else val+ csenum = let cs' = _enums cs + val = (indent "/// Constructor Enumerations") : (concatMap (map indent.lines.mshow) cs')+ in if null cs' then [] else val+ csstrc = let cs' = _structs cs+ in concatMap (map indent.lines.mshow) cs'+ csback = let cs' = _callbacks cs+ val = (indent "/// Callback functions ") : (concatMap (map indent.lines.mshow) cs')+ in if null cs' then [] else val+ imports = map mshow (_includes cs)+ in unlines $ imports ++ [""+ ,nm+ ,"{"+ ] +++ zipWith id (repeat (" /// "++)) (lines $ _header cs) +++ [" public unsafe class " ++ _class cs+ ," {"+ ] ++ [""] +++ csback ++ [""] +++ csexp +++ cspre +++ csrts +++ [" }"+ ,"}"+ ,nm ++ ".Types"+ ,"{" ] +++ zipWith id (repeat (" /// "++)) (lines $ _header cs) +++ csenum ++ [""] +++ csstrc +++ ["}"+ ]+
+ WinDll/Structs/MShow/Haskell.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- MShow instances for the Haskell datatypes+--+-----------------------------------------------------------------------------+module WinDll.Structs.MShow.Haskell() where++import WinDll.Structs.MShow.MShow+import WinDll.Structs.Folds.Haskell+import WinDll.Structs.Haskell+import WinDll.Structs.Structures hiding (Import,imports,Pragma)+import WinDll.Structs.Folds.C+import WinDll.Structs.C+import WinDll.Structs.MShow.Alignment+import WinDll.Parsers++import WinDll.Session(addParen)++import WinDll.Lib.NativeMapping++import Language.Haskell.Exts.Parser+import Language.Haskell.Exts.Syntax+import qualified Language.Haskell.Exts.Syntax as Exts++import Data.Char+import Data.List hiding(maximum)++import Prelude hiding(maximum)++import Debug.Trace++instance MShow HaskellComment where+ mshow (HaskellComment s) = "-- @@ " ++ s+ +instance MShow PragmaType where+ mshow = show+ +instance MShow GHCPragma where+ mshow (Pragma t o) = "{-# " ++ mshow t ++ " " ++ o ++ " #-}"+ +instance MShow Import where+ mshow (Import s) = "import " ++ s+ +instance MShow HSC_Let where+ mshow (HSC_Let s) = "#let " ++ s+ +instance MShow Ptr_Type where+ mshow (TypeDecL name vars typ) = "type " ++ name ++ " " ++ unwords vars ++ "= " ++ mshow typ+ 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)) = + 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)) = + let call = map toLower . show+ in "foreign import " ++ call cc ++ " \"" ++ ename ++ "\" " ++ name ++ " :: " ++ mshowM 3 typ -- (translatePartial (annWorkingSet ann) typ)+ +instance MShow HaskellFunction where+ mshow (HaskellFunction name orign typ ann _orig) = + let line1 = name ++ " :: " ++ mshowM 3 resTy -- (translatePartial typ)+ resTy = (mkIO $ translatePartial (annWorkingSet ann) typ)+ arity = tlength typ - 1 -- last argument is result type not an actual argument+ vars' = ["a"++show x|x<- [1..arity]]+ isList = (arity - 1) `elem` idx+ vars = if isList+ then init vars'+ else vars'+ size = last vars'+ pokesz = "poke " ++ size ++ " (toFFI $! length res)"+ idx = annArrayIndices ann+ front = unwords [name, unwords vars',"="]+ indent = (replicate 5 ' ' ++) -- (replicate (length front) ' ' ++)+ lines = munch mkFFI ((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"+ defs = map indent $ [unwords res] ++ if isList then [pokesz, ret] else [ret]+ in unlines $ [line1,front] ++ addDo (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) ++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))+ +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))+ else let (a:xs) = l+ in ([(a++"'", "toNative "++a)], xs, (+1))+ +munch :: Munch -> [Int] -> [String] -> [(Key, String)]+munch f idx list = munch' list 0+ where munch' :: [String] -> Int -> [(Key, String)]+ munch' [] _ = []+ munch' x n = let (v, xs, g) = f 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"+ ]+ where ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon))+ mk ty = Exts.TyFun ty ctType + +instance MShow HaskellCallback where+ mshow (Callback name ty transty orig ann) = + let arr = tlength transty - 1+ arr' = tlength orig - 1+ idx = annArrayIndices ann+ vars' = ['a':show x|x<- [1..arr]]+ vars2 = ['a':show x|x<- [1..arr']]+ isList = (arr - 1) `elem` idx+ idx' = (arr - 1) `delete` idx+ vars = if isList+ 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"+ mkUsf b = if not b then (++" unsafePerformIO $") else id+ transtyIO = isIO transty+ origIO = isIO orig+ 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 "+ ] ++ 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)+ ]+ where addDo :: [String] -> [String]+ addDo [] = [" do "]+ addDo (x:xs) = (" do " ++drop 8 x):xs+ + mkResult mnch vrs rt pk lst io dlst sat+ = let indent = (replicate 8 ' ' ++)+ lines = munch mnch dlst vrs+ 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 io && sat + then ["res" ++ replicate (inner - 3) ' ', "<- f"] ++ names+ else ["let res = f"] ++ names+ defs = map indent $ [unwords res] ++ if lst then [pk, rt] else [rt]+ in addDo (binds ++ defs)+ +instance MShow Include where+ mshow = foldInclude ((\a->"#include <"++a++">")+ ,(\a->"#include \""++a++"\"")+ )+ +instance MShow DataEnum where+ mshow = foldDataEnum ((\a b->let a' = map toLower a+ fix = init.foldr (\a b->a++","++b) [] . map (\n ->"c" ++a++n++" = " ++ ("c"++a++n))+ in "#enum Int,,"++fix b))+ where toHSC :: String -> String+ toHSC [] = []+ toHSC (x:xs) | isLower x = x : toHSC xs+ | otherwise = '_' : toLower x : toHSC xs+instance MShow HaskellStorable where+ mshow _ = error "HaskellStorable: mshow - please call mshowWithPath"+ mshowWithPath path nspace opath = foldHaskellStorable (hsstorable,hspoke,hspeek)+ where + hsstorable _name _size _ptr _vars+ _spec _pok _pek _ann = unlines' $ + ("instance " ++ inst_head ++ "Storable " ++ val_head ++ " where") + : (map indent $ (val_size _size) : + ["alignment _ = #alignment " ++ _name ++ "_t"+ ,[]+ -- ,"{-# INLINE poke #-}"+ ,inline (unlines' (map (unlines.adj.lines) _pok))+ -- ,"{-# INLINE peek #-}"+ ,"peek " ++ _ptr ++ " = do "+ ,unlines _pek+ ])+ where inst_head = case (length _vars') `compare` 1 of+ LT -> ""+ EQ -> "Storable " ++ head _vars' ++ " => "+ GT -> (mkHead ["Storable " ++ x|x<- nub _vars']) ++ " => " + -- _vars' = filter (maybe False (const True) . flip lookup convList) _vars+ _var_ = [ getResult (parseType t) | t <- _vars ]+ _vars' = [ mshowM 2 (translatePrimitive (annWorkingSet _ann) t) | t <- _var_ ]+ val_head = case (length _vars) > 0 of+ False -> _name+ True -> "(" ++ _name ++ " " ++ unwords _vars ++")"+ val_size [_] = "sizeOf _ = " ++ show (resolveAlignment path nspace opath _name [])+ val_size xs = "sizeOf _ = " ++ show (resolveAlignment path nspace opath _name xs)+ 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)+ 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+ hspeek x = inline $ unlines' $ map (unlines'.(map (indent.indent)).lines.mshow) x++instance MShow StorablePeek where+ mshow = foldStorablePeek (tag,entry,value,ret)+ where+ tag _name _ptr _type = unlines'+ ["tag' <- (#peek " ++ _name ++ "_t, tag) " ++ _ptr ++ " :: IO CInt"+ ,"newptr <- (#peek " ++ _name ++ "_t, elt) " ++ _ptr ++ " :: IO (Ptr " ++ _type ++ ")"+ ,"case tag' of"+ ]+ entry _i _childs = unlines' $+ (indent' $ show _i ++ " -> do") :+ (map (unlines'.map indent.lines) _childs)+ 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"+ 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]+ lines = zip vars args+ paren = \v -> if ' ' `elem` v then "(" ++ v ++ ")" else v+ inner = ((maximum $ map (length.fst) lines)) `max` 3+ binds = map ((\(l,v) -> unwords [l ++ replicate (inner - length l - 1) ' ', "<-", v])) lines+ in unlines' $ binds ++ ["return $ " ++ _type ++ " " ++ unwords vars]+ +instance MShow StorablePoke where+ mshow = foldStorablePoke (tag,new,val,var,ret)+ where+ tag _type _field _ptr _poke = let mk :: String -> String+ mk x = "(#poke " ++ _type ++"_t, " ++ _field ++ ") " ++ _ptr ++ " " ++ x+ in case lines (mshow _poke) of+ [_name, _rest] -> unlines' [ _rest, mk _name ]+ _rest -> mk $ unlines' _rest+ new _name _type = _name ++ " <- malloc :: IO (Ptr " ++ _type ++ ")"+ val _val = _val+ var _b _name _ren + _type _ann = let mk = if _b then "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)+ ]+ ret = "return ()"++instance MShow HaskellFile where+ mshow _ = error "HaskellFile: mshow - please call mshowWithPath"+ mshowWithPath a b c hsfile =+ unlines $ + [init $ mshowList (comments hsfile)+ ,mshowList (pragmas hsfile)+ ,"module " ++ _hsname hsfile ++ " where"+ ,[]+ ,mshowList (imports hsfile)+ ,mshowList (hsclets hsfile)+ ,mshowList (includes hsfile)+ ,mshowList (hsenums hsfile)+ ,mshowList (hstypes hsfile)+ ,mshowList (hsexports hsfile)+ ,mshowList (hsimports hsfile)+ ,init $ mshowList (hsfuncs hsfile)+ ,mshowList (hscallbacks hsfile)+ ,mshowList (hsstables hsfile)+ ,mshowListWithPath a b c (hsstorable hsfile)+ ]+ +-- | Variant of unlines that does not add a newline char after everyline, only inbetween+unlines' :: [String] -> String+unlines' [] = []+unlines' x = foldr1 (\a b->a++"\n"++b) x++maximum :: (Ord a, Num a) => [a] -> a+maximum = foldl' max 0++-- | Get The result of a parse action+getResult (ParseOk a) = a
+ WinDll/Structs/MShow/HaskellSrcExts.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- MShow instances for the Haskell-Src-Exts datatypes+--+-----------------------------------------------------------------------------+module WinDll.Structs.MShow.HaskellSrcExts(isList, isFun) where++import WinDll.Structs.MShow.MShow+import WinDll.Structs.Folds.HaskellSrcExts+import WinDll.Structs.Types+-- import WinDll.Utils.Types++import qualified Language.Haskell.Exts as Exts+import qualified Language.Haskell.Exts.SrcLoc as Span+import Language.Haskell.Exts.Pretty++import Data.List++instance MShow Exts.Name where+ mshow (Exts.Ident s) = s+ mshow (Exts.Symbol s) = s+ +instance MShow Exts.QName where+ mshow (Exts.Qual (Exts.ModuleName a) b) = a ++ "." ++ mshow b+ mshow (Exts.UnQual a) = mshow a+ mshow (Exts.Special a) = mshow a+ +instance MShow Exts.SpecialCon where+ mshow Exts.UnitCon = "()"+ mshow Exts.ListCon = "[]"+ mshow Exts.FunCon = "->"+ mshow (Exts.TupleCon b a) = []+ mshow Exts.Cons = "(:)"+ mshow Exts.UnboxedSingleCon = "()"+ +instance MShow Exts.Boxed where+ mshow Exts.Boxed = "#"+ mshow Exts.Unboxed = ""+ +instance MShow NamedTypes where+ mshow [] = []+ mshow x = "{" ++ comma (map (\(a,b)->a++"::"++mshow b) x) ++ "}"+ where comma = foldl1 (\a b->a++", "++b)+ +instance MShow AnnNamedTypes where+ mshow = mshow . map (\x->(antName x, antType x))+ +instance MShow Exts.Type where+ mshow = foldType (const . const id+ ,(\a b->a++" -> "++b)+ ,(\a b->showTuple a b mshow)+ ,(\a->"(Ptr ("++a++"))")+ ,(\a b->"(" ++ a ++ " " ++ b ++ ")")+ ,mshow+ ,mshow+ ,(\a->"("++a++")")+ ,(\a c b->a++" "++mshow c++" "++b)+ ,const+ )+ + mshowM 0 = mshow+ -- Incomplete, used to translate HS to C+ mshowM 1 = foldType (const . const id+ ,(\a b->a++" -> "++b)+ ,(\_ b->"Tuple"++show (length b)++"_t*")+ ,(\a->a++"*")+ ,(\a b->a) -- ++"_t*")+ ,mshow+ ,mshow+ ,id -- (\a->"("++a++")") -- C types can't have braces around them+ ,(\a c b->a++" "++mshow c++" "++b)+ ,const+ )+ + mshowM 2 = prettyPrint+ + mshowM 3 = fold True+ where -- I'm adding the functionality of generating a count field in the show function.+ -- I don't really want to modify the original function signature. Also+ -- In the case that the function itself returns a list, we need a foreign pointer+ -- So we can write that information back to the host.+ fold f (Exts.TyForall a b c) = (const . const id) a b (fold f c)+ fold f (Exts.TyFun a b) = (fold f a) ++" -> "++ (fold f b)+ fold f t@(Exts.TyTuple a b) = case f of+ True -> showTuple a b (fold f)+ False -> prettyPrint t+ fold f t@(Exts.TyList a) = case f of+ True -> "(Ptr ("++ (fold f a) ++ "))"+ False -> prettyPrint t+ fold f (Exts.TyApp a b) = let name = (fold True a)+ in case name of + "IO" -> name ++ " (" ++ fold f b ++ ")"+ _ -> name ++ " " ++ fold False b+ fold f (Exts.TyVar a) = mshow a+ fold f (Exts.TyCon a) = mshow a+ fold f (Exts.TyParen a) = "(" ++ (fold f a) ++ ")"+ fold f (Exts.TyInfix a b c) = (fold f a) ++ " " ++ mshow b ++ " " ++ (fold f c)+ fold f (Exts.TyKind a b) = const (fold f a) b++ mshowM 4 = fold True+ where+ fold f (Exts.TyForall a b c) = (const . const id) a b (fold f c)+ fold f (Exts.TyFun a b) = (fold f a) ++" -> "++ (fold f b)+ fold f t@(Exts.TyTuple a b) = case f of+ True -> showTuple a b (fold f)+ False -> prettyPrint t+ fold f t@(Exts.TyList a) = case f of+ True -> "(Ptr ("++ (fold f a) ++ "))"+ False -> prettyPrint t+ fold f (Exts.TyApp a b) = let name = (fold True a)+ in case name of + "IO" -> name ++ " (" ++ fold f b ++ ")"+ _ -> "(" ++ name ++ " " ++ fold False b ++ ")"+ fold f (Exts.TyVar a) = mshow a+ fold f (Exts.TyCon a) = mshow a+ fold f (Exts.TyParen a) = "(" ++ (fold f a) ++ ")"+ fold f (Exts.TyInfix a b c) = (fold f a) ++ " " ++ mshow b ++ " " ++ (fold f c)+ fold f (Exts.TyKind a b) = const (fold f a) b+++-- | Checks to see if the given type is a list. Also checks in Parens+isList :: Type -> Bool+isList (Exts.TyList _) = True+isList (Exts.TyParen a) = isList a+isList _ = False++-- | Checks to see if the given type is a function. Also checks in Parens+isFun :: Type -> Bool+isFun (Exts.TyFun _ _) = True+isFun (Exts.TyParen a) = isFun a+isFun _ = False+ +-- | A template code to show tuple+showTuple _ b f = case len > 1 of+ True -> "(Tuple"++show len++"Ptr " ++ unwords (map (adjust.f) b) ++ ")"+ False -> "(" ++ unwords (map (adjust.f) b) ++ ")"+ where adjust a = showParen (' ' `elem` a) (a++) ""+ len = length b
+ WinDll/Structs/MShow/MShow.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- MShow class definition+--+-----------------------------------------------------------------------------+module WinDll.Structs.MShow.MShow where++-- * A custom show class+class MShow a where+ mshow :: a -> String+ + mshowList :: [a] -> String+ mshowList = unlines.map mshow+ + mshowM :: Int -> a -> String+ mshowM _ = mshow+ + mshowWithPath :: String -> String -> String -> a -> String+ mshowWithPath _ _ _ = mshow+ + mshowListWithPath :: String -> String -> String -> [a] -> String+ mshowListWithPath a b c = unlines.map (mshowWithPath a b c)+ +instance MShow String where+ mshow = id+ +instance MShow a => MShow (Maybe a) where+ mshow Nothing = ""+ mshow (Just a) = mshow a+ +-- | Indenting size+tabstop :: Int+tabstop = 4+ +-- | A function to Indent things along.+indent :: String -> String+indent = ((replicate tabstop ' ') ++) + +-- | A function to Indent things halfway along.+indent' :: String -> String+indent' = ((replicate (tabstop `div` 2) ' ') ++)++-- | A function to Inline structure+inline :: String -> String+inline = drop tabstop
+ WinDll/Structs/PrettyPrinting.hs view
@@ -0,0 +1,137 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Pretty printing function for the internal datastructures+--+-----------------------------------------------------------------------------++module WinDll.Structs.PrettyPrinting where++import WinDll.Structs.Structures+import WinDll.Structs.MShow.HaskellSrcExts+import WinDll.Structs.MShow.MShow+import WinDll.Lib.NativeMapping+import WinDll.Version ( 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 " :: " .+ showString (mshow types)+ + +instance Show Header where+ showsPrec d (Header name exports) =+ showString "-- | Autogenerated by WinDll, Do not change unless you know what you're doing \n" .+ showString "module " .+ showString (name++"FFI") .+ (if null exports + then id+ else (showString "(" .+ showString + (foldl1 (\a b->a++", "++b) exports) .+ showString ")")) .+ showString " where"+ +instance Show Function where+ showsPrec d (Function name argc types _ _) =+ showString name .+ showString " :: " .+ showString (mshow types) . + showString "\n" .+ showString name .+ showString " " .+ showString (unwords args) .+ showString " = toFFI $ " .+ showString name .+ showString " " .+ showString (unwords $ map (\a->"(fromFFI "++a++")") args)+ where args = (zipWith ((. show) . (++)) (replicate argc "a") [1..])+ +instance Show DataType where+ showsPrec d (NewType name types body tag) =+ printData True d name types [body]+ showsPrec d (DataType name types body tag) =+ printData False d name types body+ showsPrec d (Constr name types) = + showString name .+ showString " " .+ showString (mshow types)+ +-- | used above to abstract between dataypes and newtypes+printData nbe d name types body = + showString (if nbe then + "newtype " else+ "data ") .+ showString name .+ showString " " .+ showString (unwords types) .+ showString " = " .+ (mkBody body) .+ showString "\ntype " .+ showString name .+ showString " " .+ showString (unwords types) .+ (if null types + then showString " = Ptr "+ else showString " = Ptr (") .+ showString name .+ (if null types then id+ else showString " " .+ showString (unwords types) .+ showString ")")+ where indent = length name + 2 * (length types) + 7+ space = replicate indent ' '+ mkConst a = showString "\n" .+ showString space . + showString "| " .+ showsPrec d a+ mkBody [] = id+ mkBody (x:xs) = showString "" . showsPrec d x . (foldl' (.) id (map mkConst xs))+ +instance Show Module where+ showsPrec d (Module header path imports exports datatypes functions _ _) =+ showsPrec d header .+ showString "\n\n-- @@Generated from \"" .+ showString path .+ showString ("\" by WinDll version " ++ verStr ++ " \n") .+ showString (unlines $ map mkImport (sort imports)) .+ showString "\n" .+ showString (mkPrec exports "") .+ showString "\n" .+ --showString (mkPrec datatypes "\n") .+ --showString "\n" .+ showString (mkPrec functions "\n") + where mkImport p = "import " ++ p+ mkPrec p0 v = (unlines (map (\a->(showsPrec d a) v) p0))+ +-- | FFI Types need to be strict, This converts the type if needed+mkStrict :: TypeName -> TypeName+mkStrict a = if "!" `isPrefixOf` a then a else "!"++a+ +-- | Look up and convert the list of types back to a function signature to be printed. +-- Admittedly this only supports simple functions, but these are enough for now (I don't know how FFI deals with functions as arguments)+showTypes :: String -> [TypeName] -> String+showTypes _ [] = []+showTypes f types = foldl1 (\a b->a++f++b) types++-- | 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+ nums = [1..(length export)]+ list = (zipWith ($) (gmap (\a b->"\t"++a++"\t@"++show b) export) nums)
+ WinDll/Structs/Structures.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Structures used in WinDll +-- +----------------------------------------------------------------------------- + +module WinDll.Structs.Structures(module WinDll.Structs.Structures + ,module WinDll.Structs.Types + ,module WinDll.Utils.TypeFolds) where + +import qualified Language.Haskell.Exts as Exts +import qualified Language.Haskell.Exts.SrcLoc as Span + +import Data.Data hiding (DataType) +import Data.Typeable +import Data.Monoid +import Data.Maybe +import Data.List +import Control.Arrow + +import Data.Generics hiding (DataType) + +import WinDll.Structs.Folds.HaskellSrcExts +import WinDll.Structs.MShow.HaskellSrcExts +import WinDll.Structs.MShow.MShow +import WinDll.Structs.Types +import WinDll.Utils.TypeFolds + +import qualified Debug.Trace as D + +type DataTypes = [DataType] +type Instances = [Instance] + +-- | Simplifies a a type, this basically just removes top level parents +stripTop :: Type -> Type +stripTop (Exts.TyParen a) = stripTop a +stripTop b = b + +-- | Split the type in head and tail in the cases of -> (future work, when we suppor higherorder functions) and ($) types, else just return Nothing +getHead :: Type -> Maybe TypeName +getHead (Exts.TyApp a b) = Just (head $ collectTypes a) +getHead (Exts.TyParen a) = getHead a +getHead x = Nothing + +-- | A function to select all occurences of one type with another +replaceTypes :: TypeNames -> TypeNames -> Type -> Type +replaceTypes in_ out_ = everywhere (mkT inner) + where inner :: Exts.Name -> Exts.Name + inner (Exts.Ident s) = Exts.Ident (find s) + inner (Exts.Symbol s) = Exts.Ident (find s) + + find s = maybe s (out_!!) (findIndex (==s) in_) + +-- * Datatype declarations + +-- | A special type consisting of a tuple of all the comments that belong to a specific decl. +-- Basically the "matched" comments +type CommentDecl = ([String],Exts.Decl) + +-- | Module export declarations. +data Export = Export { exName :: Name -- ^ The original name of the function to be exported + , 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 + } + deriving(Eq,Data,Typeable) + +-- | Module header declaration. Contains the module name that was just parsed. And a list of +-- exported function which is used to avoid compile errors if a function was marked to be +-- exported but is not visible outside the module. +data Header = Header { headername :: Name + , exportname :: [ExportName] + } + deriving(Eq,Data,Typeable) + +-- | Datatype and Newtype declarations Tagged with some extra information +-- 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 + 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 +isSimpleData (NewType _ a _ _) = null a +isSimpleData _ = error "isSimpleData: Cannot be called with anything other than DataType and NewType" + +-- | TypeDecl datatype +data TypeDecL = TypeDecL { typeName :: Name -- ^ @typeName@ The type name + , typeVars :: [TypeName] -- ^ @typeVars@ The free variables of the type + , repTypes :: Type -- ^ @repTypes@ The type represented by this type + } + | TypeDecN { typeName :: Name -- ^ @typeName@ The type name + , typeVars :: [TypeName] -- ^ @typeVars@ The free variables of the type + , repTypes :: Type -- ^ @repTypes@ The type represented by this type + } + deriving(Show,Eq,Data,Typeable) + +-- | Check if this type is a closed type. e.g. has no type variables. In which case we can do replacements +-- instead of unification (which would fail. on these types). +isClosed :: TypeDecL -> Bool +isClosed = null . typeVars + +-- | A method to lift a Exts.Type to a TypeDecL +-- But since no name is defined for any arbitrary lifted type then this method +-- should generate an exception if you try to inspect the name field of this +-- TypeDecL. As such it is set to undefined. +liftType :: Type -> TypeDecL +liftType t = TypeDecL undefined (collectTypeVars t) t + +-- | Get the name of a datatype +getName :: DataType -> Name +getName (NewType name _ _ _) = name +getName (DataType name _ _ _) = name +getName _ = error "getName: Cannot be called with anything other than DataType and NewType" + +-- | Get the types of the constructors in the datatypes that might need specialization +-- Due to a bug this sill no longer emit Applied types on Type vars +getTypes :: DataType -> [Type] +getTypes (NewType _ _ t _) = getTypes t +getTypes (DataType _ _ t _) = concatMap getTypes t +getTypes (Constr _ t) = filter hasVars $ map antType t + +-- | Checks to see if this type is a TyVar +isVar :: Type -> Bool +isVar (Exts.TyVar _) = True +isVar _ = False + +-- | Checks to see if the given type has any type variables +hasVars :: Type -> Bool +hasVars = null . listify isVar + +-- | Function declaration +data Function = Function { fnName :: Name -- ^ The function name + , fnArity :: Int -- ^ The arity of the function + , fnType :: Type -- ^ The preprocessed type (to support lists etc) + , fnAnn :: Ann -- ^ The accompanying function type annotations + , fnOrigType :: Type -- ^ The original unmodified type + } + deriving(Eq,Data,Typeable) + +type Opt = String + +-- | A mapping for a sigle callback function, holds the definition for callback functions +data Callback = Callback{ cbName :: Name -- ^ The name of the callback function + , cbOrigType :: Type -- ^ The initial type of the function + , cbNewType :: Type -- ^ The marshalable callback function. + , cbInputType :: Type -- ^ The unprocessed type + , cbAnn :: Ann -- ^ Type Annotations + } + 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 + } + deriving(Eq,Show,Data,Typeable) + +-- | Datatype to hold user defined pragmas +data Pragma = Pragma Name [Opt] + deriving(Show,Eq,Data,Typeable) + +-- | complete parsed module definition. Used as the main AST for this preprocessor +data Module = Module { header :: Header + , filepath :: FilePath + , imports :: [Import] + , exports :: [Export] + , datatypes :: DataTypes + , functions :: [Function] + , instances :: Instances + , types :: [TypeDecL] + } + deriving(Eq,Data,Typeable) + +instance Monoid Module where + mempty = Module undefined [] [] [] [] [] [] [] + mappend (Module _ _ i1 e1 d1 f1 o1 t1) + (Module _ _ i2 e2 d2 f2 o2 t2) = Module (Header "Internal.Merged" []) [] (i1++i2) (e1++e2) (d1++d2) + (f1++f2) (o1++o2) (t1++t2) + +-- | A datatype used originally to replace the dual constructor type of the +-- comment format used by Haskell-src-exts. However since that was changed in +-- the newer versions of the library, this datatructure should be refactored out. +data MyComment = MyComment Span.SrcSpan String + deriving (Eq,Ord,Show,Data,Typeable) + +-- | A datatype to hold instance declaration names. These are just used to check so +-- that we don't redefine already existing instances +data Instance = Instance Types -- ^ Default constructor for only Storable classes + | QualifiedInstance Name Types -- ^ The rest, A fully qualified instance + deriving(Eq,Ord,Show,Data,Typeable) + +-- | A datatype to hold the type's fullname (including module name) +-- whether it has been evaluated by the preprocessor +-- and whether it's been resolved to a user-defined type or a Primitive type +-- To be used in the next version. +data TypeTag = TypeTag String Bool Bool + | NoTag + deriving(Eq,Ord,Show,Data,Typeable) + +-- | A simpler kind of Unification to solve type synonyms. I call it unification +-- because I can't think of another name. +unifyType :: TypeDecL -> Type -> Type +unifyType tdecl t = + foldType ((\a b c->Exts.TyForall a b (rep c)) + ,(\a b ->Exts.TyFun (rep a) (rep b)) + ,(\a b ->Exts.TyTuple a (map rep b)) + ,Exts.TyList . rep + ,(\a b ->rep $ Exts.TyApp a (unifyType tdecl b)) + ,Exts.TyVar + ,Exts.TyCon + ,Exts.TyParen . rep + ,(\a c b->Exts.TyInfix (rep a) c (rep b)) + ,(\a b ->Exts.TyKind (rep a) b) + ) t + where rep :: Type -> Type + rep p = if adj True p then make p else p + + name = typeName tdecl + + make p = let vars = typeVars tdecl + rigs = tail $ collectRealTypes p + in case length vars == length rigs of + False -> error $ "Panic: cannot unify type " ++ mshowM 2 p ++ + " with type " ++ mshowM 2 (repTypes tdecl) ++ + " . reason: not enough type variables" + True -> fillType (zip vars rigs) (repTypes tdecl) + + fillType :: [(TypeName, Type)] -> Type -> Type + fillType lst = + foldType ((\a b c->Exts.TyForall a b c) + ,(\a b->Exts.TyFun a b) + ,(\a b->Exts.TyTuple a b) + ,Exts.TyList + ,(\a b->Exts.TyApp a b) + ,(\a -> fromJust $ lookup (mshow a) lst) + ,Exts.TyCon + ,Exts.TyParen + ,(\a c b->Exts.TyInfix a c b) + ,(\a b ->Exts.TyKind a b) + ) + + adj :: Bool -> Type -> Bool + adj top t@(Exts.TyCon h) = mshow h == name && not top + adj top t@(Exts.TyVar h) = mshow h == name && not top + adj _ t@(Exts.TyApp l r) = adj False l + adj _ x = False
+ WinDll/Structs/Types.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Types used when describing structures in WinDll+--+-----------------------------------------------------------------------------+module WinDll.Structs.Types where++import qualified Language.Haskell.Exts as Exts+import qualified Language.Haskell.Exts.SrcLoc as Span++import Data.Generics hiding (DataType)+import Data.List ( nub )+import Data.Monoid++type Name = String+type Import = String+type ExportName = String+type Type = Exts.Type+type TypeName = String+type TypeNames = [TypeName]+type NamedTypes = [(Name,Type)]+type AnnNamedTypes = [AnnType]+type Types = [Type]++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)++-- | 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+ , annArrayIsList :: Bool -- ^ Indicates if the field type is a List type. + , annStableIndices :: [Int] -- ^ Indices/Offsets to indicate whether this function has any StablePtr values+ , annWorkingSet :: [(String, String)] -- ^ Copy of the definition list for the Haskell translation functions+ , 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+ }+ deriving(Show,Eq,Data,Typeable)+ +instance Eq (Bool -> [(String, String)]) where+ f == g = f False == g False && f True == f True++instance Show (Bool -> [(String, String)]) where+ 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+ }+ deriving(Show,Eq,Data,Typeable)+ +-- | Generic empty annotation+noAnn :: Ann+noAnn = Ann { annArrayIndices = []+ , annArrayIsList = False+ , annStableIndices = []+ , annWorkingSet = []+ , annWorkingSetC = []+ , annWorkingSetCSize = []+ , annWorkingSetCs = const []+ }++-- | Find any Names embedded within any arbitraty structures+findStrings' :: Data a => a -> [String] -- Language.Haskell.Exts.Syntax.Name -> [String]+findStrings' = everything (++) ([] `mkQ` inner)+ where inner (Exts.Ident s ) = [s]+ inner (Exts.Symbol s) = [s]
+ WinDll/Utils/DepScanner.hs view
@@ -0,0 +1,68 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- Module to do dependency tracing so that all source files can be +-- traversed and all data structures resolved+--+-----------------------------------------------------------------------------++module WinDll.Utils.DepScanner where++import WinDll.Session+import WinDll.Utils.Feedback++import GHC+import GHC.Paths ( libdir )+import DynFlags+import System.Environment+import System.Directory++-- | This module is self contained, So it can be used on it's own.+main :: IO ()+main = do+ args <- getArgs+ when (not $ null args) $ + do deps <- getDeps (head args)+ putStrLn (unwords deps) ++-- | Trace the sessions dependencies+traceDeps :: Exec ()+traceDeps = do+ session <- get+ let file = mainFile session+ path = absPath session+ inform _normal $ "Tracing dependencies of file '" ++ file ++ "'"+ exists <- liftIO $ doesFileExist path+ when (not exists) $ do+ die $ "File does not exist '" ++ file ++ "'"+ + inform _detail ("Reading file '" ++ file ++ "'")+ deps <- liftIO (getDeps file)+ let payload = (workingset session) { dependencies = deps }+ put $ session { workingset = payload }+ inform _detail "Dependencies traced."+ inform _detail ("Dependencies are: " ++ unwords deps)+ +-- | Get the depencies of the supplied file as a list of strings+getDeps :: String -> IO [String]+getDeps file = fmap (fmap (moduleNameString . ms_mod_name)) (getGraph file)++-- | Get the module dependency graph of the given file+getGraph :: String -> IO ModuleGraph+getGraph file = + defaultErrorHandler defaultDynFlags $ do+ runGhc (Just libdir) $ do+ dflags <- getSessionDynFlags+ setSessionDynFlags $ dflags { ghcMode = MkDepend , ghcLink = NoLink }+ target <- guessTarget file Nothing+ setTargets [target] + load LoadAllTargets+ getModuleGraph+
+ WinDll/Utils/Feedback.hs view
@@ -0,0 +1,73 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Code to facilitate giving feedback +-- +----------------------------------------------------------------------------- + +module WinDll.Utils.Feedback where + +import WinDll.Session + +import Control.Monad.State + +import System.IO.Unsafe +import System.Exit +import System.Directory + +-- | 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 +-- +-- The debug levels are: +-- 0 - Off +-- 1 - Informational +-- 2 - Detailed informational +inform :: Int -> String -> Exec () +inform level msg = + do session <- get + let dbg = verbosity session + liftIO $ when (level <= dbg && dbg /= 0) $ putStrLn ("*** " ++ msg) + return () + +-- | Normal Information message +_normal = 1 :: Int + +-- | Detauled Information message +_detail = 2 :: Int + +-- | Give the user a warning and exits if warnings are treated like errors +warn :: String -> Exec () +warn msg = + do session <- get + let werr = warnings_as_errors session + let warnings_enabled = warnings session + liftIO $ when (warnings_enabled && not werr) $ putStrLn ("Warning: " ++ msg) + if werr then die msg + else return () + +-- | Give the user a Error and exit +die :: String -> Exec a +die msg = (liftIO $ putStrLn ("Error: " ++ msg)) >> cleanup >> liftIO exitFailure + +-- | Cleanup any temporary files we might have written, if the value keep_temps has not been set. +cleanup :: Exec () +cleanup = + do inform _normal "Cleaning up...." + session <- get + let build = pipeline session + dir = dirPath build + case keep_temps session || null (files build) of + True -> inform _detail "Nothing to clean up." + >> when (keep_temps session) (liftIO $ putStrLn $ "Preserved " ++ dir) + False -> mapM_ (\a->inform _detail ("Cleaning '" ++ a ++ "'...") >> liftIO (removeFile (dir++a))) (files build) + >> inform _detail ("Removing " ++ dir ++ "...") + >> liftIO (removeDirectoryRecursive dir) + + inform _detail "Cleanup done..."
+ WinDll/Utils/HaddockRead.hs view
@@ -0,0 +1,92 @@+-----------------------------------------------------------------------------+-- |+-- Module : WinDll.Utils.HaddockRead +-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- A module to handle parsing and information querying of Haddock files+--+-----------------------------------------------------------------------------++module WinDll.Utils.HaddockRead where++import System.Environment+import System.Directory++import qualified Data.Map as M++import System.FilePath++import WinDll.Utils.Processes+import WinDll.Session+import WinDll.Utils.Feedback+import System.FilePath++import Data.List+import Data.Char++type FunctionName = String+type Arg = Int+type IndexedInterface = M.Map FunctionName FunctionSpec++data FunctionSpec = + FunctionSpec { description :: [String]+ , arguments :: [(Arg,String)]+ } deriving Show++-- | Read the function comments of the specified haddock file and create a simple datastructure to hold em.+getDocumentationInfo :: Exec IndexedInterface+getDocumentationInfo = + do session <- get+ let comment = pres_comment session+ build = pipeline session+ case comment of+ False -> return M.empty+ True -> do createProcess Nothing "haddock" createHoogle+ specs <- liftIO $ fmap lines $ readFile ((addTrailingPathSeparator (dirPath build)) ++ "main.txt")+ return $ parseHaddock specs M.empty+ +-- | Parse the haddock generated file and produce the map required+parseHaddock :: [String] -> IndexedInterface -> IndexedInterface+parseHaddock [] _map = _map+parseHaddock value _map + = let value' = dropWhile (\x->not $ "-- |" `isPrefixOf` x) value+ (comments,rest) = span (\x->"-- " `isPrefixOf` x) value'+ (func:rest') = rest+ isFunction x = case x of+ ':' -> True+ _ -> False+ name = takeWhile (\x-> not $ (isFunction x) || isSpace x) func+ isPart x = case x of+ '-' -> True+ ' ' -> True+ '|' -> True+ _ -> False+ comment = concatMap (reverse . dropWhile isSpace . reverse . dropWhile isPart) comments+ cmt' = cleanupHaddock comment []+ specs = FunctionSpec (([]:cmt')++[[]]) []+ in if null rest || null name then _map else parseHaddock rest' (M.insert name specs _map)+ +-- | Convert a long string into a haddock representation by splitting "." as newlines.+cleanupHaddock :: String -> String -> [String]+cleanupHaddock [] r = [reverse r]+cleanupHaddock (' ':'.':' ':x) r = reverse r : cleanupHaddock x []+cleanupHaddock ('<':'a':'>':x) r = cleanupHaddock x ('"':r)+cleanupHaddock ('<':'/':'a':'>':x) r = cleanupHaddock x ('"':r)+cleanupHaddock (c:x) r = cleanupHaddock x (c:r)+ +-- | Generate hoogle documentation+createHoogle :: Exec (String, [String])+createHoogle = + do session <- get+ let dir = addTrailingPathSeparator (baseDir session)+ deps = (dependencies.workingset) session+ paths = (absPath session : map guessPath (drop 1 deps))+ return ("main.txt"+ , -- ["--optghc=\"-i" ++ if ' ' `elem` dir then show dir else dir ++ "\"" + ("--hoogle" : map (dir++) paths)+ )
+ WinDll/Utils/Pragma.hs view
@@ -0,0 +1,76 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- This module contains the basic Pragma processing functions +-- to handle custom pragmas. Or specifically, those updating +-- the lookup lists. +-- +----------------------------------------------------------------------------- + +module WinDll.Utils.Pragma where + +import WinDll.Session +import WinDll.Utils.Feedback +import WinDll.Structs.Structures +import WinDll.Lib.Native + +-- | Retreive the pragmas matching the given directive +getPragmas :: String -> [Pragma] -> [Pragma] +getPragmas str = filter (\(Pragma s _)->s==str) + +-- | Validate a pragma based on the given mask. '#' are taken to be a +-- single string entry, spaces indicate a next element. +-- The mask "# #@#" is taken as two elements, where the second one +-- consists of two strings seperated by a @ sign. +validate :: String -> Pragma -> Exec Pragma +validate mask p@(Pragma nm ld) + = do guard (not $ isValid (words mask) ld) >> + (die $ "Syntax error in Pragma " ++ nm ++ ", supplied value '" + ++ unwords ld ++ "' does not match mask '" ++ mask ++ "'") + return p + where isValid :: [String] -> [String] -> Bool + isValid [] [] = True + isValid (x:xs) (y:ys) = cmp x y && isValid xs ys + isValid _ _ = False + + cmp :: String -> String -> Bool + cmp ('#':xs) str = let (fs, sn) = span (/='@') str + in cmp xs sn + cmp ('@':xs) ('@':str) = cmp xs str + cmp [] [] = True + cmp _ _ = False + +-- | Process the four convertion pragmas and create the +-- proper conversion sets +processConversionPragmas :: [Pragma] -> Session -> Exec Session +processConversionPragmas prg session + = do hs2c <- mapM (validate "# #@#") $ getPragmas "HS2C" prg + hs2cs <- mapM (validate "# #" ) $ getPragmas "HS2C#" prg + hs2hs <- mapM (validate "# #" ) $ getPragmas "HS2HS" prg + + put session + updateFromPragma hs2c updt1 (\x y->y{n_hs2c =x ++ nativeLisths2c}) + updateFromPragma hs2c updt2 (\x y->y{n_csize=x ++ nativeC_sizes}) + updateFromPragma hs2cs updt3 (\x y->y{n_hs2cs= \b -> x ++ nativeCslist b}) + updateFromPragma hs2hs updt4 (\x y->y{n_hs2hs=x ++ nativeConvList}) + get + where updt1 [x,y] = (x, takeWhile (/='@') y) + updt2 [x,y] = (x, read $ tail (dropWhile (/='@') y)) + updt3 [x,y] = (x, y) + updt4 [x,y] = (x, y) + +-- | Update a session by processing the values inside the given Pragmas +updateFromPragma :: [Pragma] -> ([String] -> (a, b)) -> ([(a, b)] -> WorkingSet -> WorkingSet) -> Exec () +updateFromPragma prg process update + = do session <- get + let results = map (\(Pragma _ lst)->process lst) prg + let wrk = update results (workingset session) + put $ session{workingset = wrk} +
+ WinDll/Utils/Processes.hs view
@@ -0,0 +1,217 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- The main entry file for the preprocessor+-- part of the WinDll suite+--+-----------------------------------------------------------------------------++module WinDll.Utils.Processes where++import WinDll.Builder+import WinDll.Session+import WinDll.Utils.Feedback+import WinDll.EntryPoint++import Control.Monad++import System.Random+import System.FilePath+import System.Directory+import System.IO+import System.IO.Error+import System.Environment+import System.Process hiding (createProcess)+import qualified System.Process as Proc+import System.Exit++import GHC.Paths++import Paths_Hs2lib++type Process = FilePath -> Exec (String,[String]) -> Component++-- | Create and run processes+createProcess :: Maybe FilePath -> Process+createProcess wd name robot =+ do (outfile,args) <- robot+ session <- get+ let build = pipeline session+ fullfile = dirPath build+ args' = map (strReplace "%filepath" fullfile) args+ proc' = name ++ (case platform session of+ Unix -> ""+ Windows -> ".exe")+ inform _normal ("*** running " ++ name ++ "...") + inform _detail ("*** " ++ proc' ++ " " ++ unwords args')+ (pcode) <- + liftIO $ do try $ Proc.createProcess + (proc proc' args'){ cwd = wd `mplus` Just (fullfile)+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ + (code,_out) <- case pcode of+ Left err -> die ("Error running process '" ++ name ++ "' \n\t" ++ show err)+ Right code -> readWhileWaitForProcess code+ case code of+ ExitSuccess -> do inform _detail _out+ inform _normal ("*** process completed successfully.") + inform _detail ("*** Writing " ++ fullfile ++ outfile)+ put $ session { pipeline = build { files = outfile :(files build) } }+ (ExitFailure _) -> do inform _detail _out + inform _normal ("*** process failed.") + die ("remote fault. failed to create " ++ outfile)++-- | A helper function to loop and print only the information i want out.+readWhileWaitForProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Exec (ExitCode,String)+readWhileWaitForProcess full@(_, Just hout, Just herr, proccode) + = do ret <- liftIO $ getProcessExitCode proccode + case ret of+ Just c -> liftIO ( hGetContents hout >>= (\v->hClose hout>>return v) ) + >>= (\val -> return (c, val))+ Nothing -> do p <- liftIO $ try (hLookAhead herr)+ case p of + Right '[' -> (liftIO $ putStrLn =<< hGetLine herr) + >> readWhileWaitForProcess full+ Right 'L' -> (liftIO $ putStrLn =<< hGetLine herr) + >> readWhileWaitForProcess full+ Right _ -> (liftIO $ hGetLine herr)+ >>= inform _normal + >> readWhileWaitForProcess full+ Left _ -> readWhileWaitForProcess full -- will hopefully exit+ +-- | Run the entire compilation pipeline.+runCompilePipeLine :: Exec ()+runCompilePipeLine = do inform _normal "Compiling..." ++ session <- get++ env <- liftIO $ getEnvironment+ let vsbin = maybe "." addTrailingPathSeparator (lookup "VSBIN" env)+ + createProcess Nothing "ghc" createDllMain+ createProcess Nothing "hsc2hs" createHSfile+ createProcess Nothing "ghc" createDLL+ + when (mvcpp session) $ createProcess (Just vsbin) "lib" createLIB+ + moveAllFiles++-- | Create the dllMain c file.+createDllMain :: Exec (String,[String])+createDllMain = do session <- get+ return ("dllmain.o",["-c"] + ++ (if (platform session) == Windows then [] else ["-fPIC"]) +++ ["dllmain.c"])++-- | Process hsc file+createHSfile :: Exec (String,[String])+createHSfile = do session <- get+ let out_ = namespace session ++ ".hs"+ in_ = namespace session ++ ".hsc"+ ghc_ = reverse $ dropWhile (/=pathSeparator) $ reverse libdir+ odir = outputDIR session+ ldir = addTrailingPathSeparator (baseDir session) ++ "Includes"+ cc1 = ghc_ ++ "mingw" + ++ [pathSeparator] ++ "libexec"+ ++ [pathSeparator] ++ "gcc"+ ++ [pathSeparator] ++ "mingw32"+ ++ [pathSeparator] ++ "3.4.5"+ ++ [pathSeparator] ++ "cc1.exe"+ ldir2 <- liftIO $ getDataFileName "Includes" + + return (out_+ ,["-o" ++ out_ + ,"-I" ++ ldir+ ,"-I" ++ ldir2+ , in_ ]) --, "-c " ++ cc1])++-- | Create the final shared lib+createDLL :: Exec (String,[String]) +createDLL = do session <- get+ let output = outputFile session+ name = namespace session+ extra = "HS" ++ name ++ ".a"+ odir = outputDIR session+ build = pipeline session+ fullfile = dirPath build+ os = platform session+ dir = baseDir session+ return (output,["-fglasgow-exts"+ ,"--make"+ ] + ++ (if os == Windows then [] else ["-fPIC"]) +++ ["-shared"+ ,"-o" ++ output+ ,fullfile ++ name ++ ".hs"+ ,"dllmain.o"+ ]+ ++ (if os == Windows then ["exports.def"] else []) + ++ (if link_dynamic session then ["-dynamic"] else [])+ ++ (if threaded session then ["-threaded"] else []) + ++ ["-fno-warn-deprecated-flags"+ ,"-O2"+ ,"-package ghc"+ ,"-i" ++ if ' ' `elem` dir then show dir else dir+ --,"-outputdir " ++ if ' ' `elem` odir then show odir else odir+ ,"-optl --enable-stdcall-fixup"+ --,"-optl --disable-stdcall-fixup"+ ,"-optl-Wl,-s"+ ,"-funfolding-use-threshold=16"+ ,"-optc-O3"+ ,"-optc-ffast-math"+ -- ,"-fno-full-laziness" -- due to calls to unsafePerformIO+ -- ,"-fno-cse" -- prevent any cse to be performed.+ -- ,"-prof"+ -- ,"-auto-all"+ -- ,"-caf-all"+ ])++-- | Create the MSVC++ lib+createLIB :: Exec (String,[String])+createLIB = do session <- get+ let name = namespace session+ odir = addTrailingPathSeparator $ outputDIR session+ lib = name ++ ".lib"+ def = "exports.lib"+ return (lib, ["/DEF:\""++odir ++ "exports.def\""+ ,"/out:\"" ++ odir ++ lib ++ "\""])+ + +-- | Move all the required files to their final destinations +moveAllFiles :: Exec ()+moveAllFiles = do session <- get+ let output = outputFile session+ name = namespace session+ extra = "HS" ++ name ++ ".a"+ header = name ++ ".h"+ ffi = name ++ "_FFI.h"+ csfile = name ++ ".cs"+ lib = name ++ ".lib"+ odir = addTrailingPathSeparator $ outputDIR session+ build = pipeline session+ fullfile = dirPath build+ liftIO $ copyFile (fullfile++output) (odir++output)+ liftIO $ copyFile (fullfile++"HSdll.dll.a") (odir++extra)+ + when (cpp session) $ + do liftIO $ copyFile (fullfile++header) (odir++header)+ liftIO $ copyFile (fullfile++ffi) (odir++ffi)+ + when (csharp session) $ + liftIO $ copyFile (fullfile++csfile) (odir++csfile)+ + when (mvcpp session) $ + liftIO $ copyFile (fullfile++lib) (odir++lib)+ when (incDef session) $ + liftIO $ copyFile (fullfile++"exports.def") (odir++name++".def")+ + inform _normal "Files copied."
+ WinDll/Utils/TypeFolds.hs view
@@ -0,0 +1,227 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Structures used in WinDll +-- +----------------------------------------------------------------------------- +module WinDll.Utils.TypeFolds where + +import qualified Language.Haskell.Exts as Exts +import qualified Language.Haskell.Exts.SrcLoc as Span + +import Data.Data hiding (DataType) +import Data.Typeable +import Data.Monoid +import Data.Maybe +import Data.List +import Control.Arrow + +import Data.Generics hiding (DataType) + +import WinDll.Structs.Folds.HaskellSrcExts +import WinDll.Structs.MShow.HaskellSrcExts +import WinDll.Structs.MShow.MShow +import WinDll.Structs.Types + +-- | A length function to determine the arrity of a type +tlength :: Type -> Int +tlength = foldType (const . const id + ,(+) + ,const . const 1 + ,const 1 + ,const . const 1 + ,const 1 + ,const 1 + ,id + ,const . const . const 1 + ,const . id + ) + +-- | Split a type up at the TyFun's. So we can determine the different parts of a function +-- This function has clearly a problem with higher-rank functions. But since we don't support +-- those anyway. No Harm no foul for now. +splitType :: Type -> [Type] +splitType = foldType ((\a b c->map (Exts.TyForall a b) c) + ,(++) + ,(\a b-> [Exts.TyTuple a (concat b)]) + ,map Exts.TyList + ,zipWith Exts.TyApp + ,(:[]) . Exts.TyVar + ,(:[]) . Exts.TyCon + ,map Exts.TyParen + ,(\a c b->zipWith (flip Exts.TyInfix c) a b) + ,(\a b-> map (flip Exts.TyKind b) a) + ) + +-- | Flattens a Type down to a single string by concatening the elements it's composed of +flattenToString :: Type -> String +flattenToString = foldType ((\a b c-> "Forall" ++ c) + ,(\a b-> a ++ "To" ++ b) + ,(\a b -> "Tuple" ++ concat b) + ,(\a -> "List" ++ a) + ,(++) + ,mshowM 2 + ,mshowM 2 + ,id -- (\a -> "Parens" ++ a) + ,(\a b c->"Infix" ++ a ++ show b) + ,(\a b -> "Kind" ++ a) + ) + +-- | A function to collect all types from a type +collectTypeVars :: Type -> TypeNames +collectTypeVars = + foldType (const . const id + ,(++) + ,const concat + ,id + ,(++) + ,(:[]).mshow + ,const [] + ,id + ,(\a _ b->a++b) + ,const + ) + +-- | A function to collect all type variables from a type +collectTypes :: Type -> TypeNames +collectTypes = foldType (const . const id + ,(++) + ,const concat + ,id + ,(++) + ,(:[]).mshow + ,(:[]).mshow + ,id + ,(\a _ b->a++b) + ,const + ) + +-- | A function to collect all type variables from a type, +-- except type applications are stucturally preserved. +collectLessTypes :: Type -> TypeNames +collectLessTypes = foldType (const . const id + ,(++) + ,const concat + ,id + ,\x -> (:[]) . unwords . (++) x + ,(:[]).mshow + ,(:[]).mshow + ,id + ,(\a _ b->a++b) + ,const + ) + +-- | A function to collect all type variables from a type but +-- any applied type in the excempt list will be ignored. +collectTypesEx :: TypeNames -> Type -> TypeNames +collectTypesEx h = foldType (const . const id + ,(++) + ,const concat + ,id + ,mk + ,(:[]).mshow + ,(:[]).mshow + ,id + ,(\a _ b->a++b) + ,const + ) + where mk a b = if any (flip elem h) a then [] else a ++ b + +collectRealTypes :: Type -> [Type] +collectRealTypes = foldType (const . const id + ,(++) + ,const concat + ,map Exts.TyList + ,(++) + ,(:[]). Exts.TyVar + ,(:[]). Exts.TyCon + ,id + ,(\a _ b->a++b) + ,const + ) + +-- | A function to find the Type at the left side of TyApp and return the RHS and the original in a tuple +selectType :: TypeName -> Type -> [(Name,TypeNames)] +selectType name = everything (++) ([] `mkQ` adj) + where cast = id :: TypeName -> Name + adj :: Type -> [(Name,TypeNames)] + adj (Exts.TyApp h t) = case collectTypes h of + [] -> [] -- should never happen + (x:_) -> case x == (cast name) of + True -> [(cast name,collectTypes t)] + False -> selectType name t + adj _ = [] + +-- | A function to find the Type at the left side of TyApp and return the RHS and the original in a tuple +-- But preserving semantics, needed for specializations. +selectTypePre :: TypeName -> Type -> [(Name,Types)] +selectTypePre name = adj True + where cast = id :: TypeName -> Name + adj :: Bool -> Type -> [(Name,Types)] + adj _ z@(Exts.TyApp h t) = case collectTypes h of + [] -> [] -- should never happen + (x:_) -> case x == (cast name) of + True -> let value = case isComplex t of + True -> [t] + False -> tail (make z) + in [(cast name,value)] + False -> adj False t + adj _ (Exts.TyForall a b c) = adj False c + adj _ (Exts.TyFun a b) = (adj False a) ++ (adj False b) + adj f (Exts.TyTuple a b) = let val = concatMap (adj f) b + in case f of + True -> val + False -> map (second ((:[]) . Exts.TyTuple a)) val + adj f (Exts.TyList a) = let val = adj f a + in case f of + True -> val + False -> map (second (map Exts.TyList)) val + adj _ (Exts.TyVar a) = [] + adj _ (Exts.TyCon a) = [] + adj _ (Exts.TyParen a) = adj True a + adj _ (Exts.TyInfix a b c) = (adj False a) ++ (adj False c) + adj _ (Exts.TyKind a b) = adj False a + + make :: Type -> [Type] + make = listify isSimple + + isComplex (Exts.TyParen a) = isComplex a + isComplex (Exts.TyList{} ) = True + isComplex (Exts.TyTuple{}) = True + isComplex (Exts.TyApp{} ) = True + isComplex _ = False + + isSimple (Exts.TyVar _) = True + isSimple (Exts.TyCon _) = True + isSimple _ = False + +-- | A function to find swap out whole type declarations +-- This is wrong, It should be type unification. +-- TODO: Fix it, It's critical +swapTypes :: TypeName -> Type -> Type -> Type +swapTypes name template t = (\(Exts.TyParen f)->f) $ + foldType ((\a b c->Exts.TyForall a b (rep c)) + ,(\a b->Exts.TyFun (rep a) (rep b)) + ,(\a b->Exts.TyTuple a (map rep b)) + ,Exts.TyList . rep + ,(\a b->Exts.TyApp (rep a) (rep b)) + ,Exts.TyVar + ,Exts.TyCon + ,Exts.TyParen . rep + ,(\a c b->Exts.TyInfix (rep a) c (rep b)) + ,(\a b->Exts.TyKind (rep a) b) + ) (Exts.TyParen t) + where rep :: Type -> Type + rep p = if adj p then template else p + + adj :: Type -> Bool + adj t@(Exts.TyCon h) = mshow h == name + adj t@(Exts.TyVar h) = mshow h == name + adj x = False
+ WinDll/Utils/Types.hs view
@@ -0,0 +1,68 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- General Util functions for the Haskell-Src-Exts datatypes +-- +----------------------------------------------------------------------------- +module WinDll.Utils.Types where + +import Language.Haskell.Exts + +import Data.Generics (everywhere, mkT, everything, mkQ) + +import WinDll.Structs.Folds.HaskellSrcExts + +class Simplify a where + simplify :: a -> a + +instance Simplify a => Simplify [a] where + simplify = map simplify + +instance Simplify Type where + simplify = simplifyParenthesis +-- | This function strips all unneeded parenthesis and keeps +-- only the bare minimum or parenthesis in types. We do this +-- to normalize the types and makes them easier to compare. +simplifyParenthesis :: Type -> Type +simplifyParenthesis = addParen . stripParen + +-- | This function strips all parenthesis from a type. +stripParen :: Type -> Type +stripParen = everywhere (mkT isParen) + where isParen :: Type -> Type + isParen (TyParen a) = a + isParen x = x + +-- | Adds the bare minimum of parenthesis to a type. This +-- requires that 'stripParen' was called first. +addParen :: Type -> Type +addParen = everywhere (mkT mkFun) + where mkFun :: Type -> Type + mkFun (TyFun a b) = if hasFun a + then TyFun (TyParen a) b + else TyFun a b + mkFun (TyApp a b) = if hasFun b || hasApp b + then TyApp a (TyParen b) + else TyApp a b + mkFun x = x + +-- | Checks to see if a type contains a function application (->) +hasFun :: Type -> Bool +hasFun = everything (||) (False `mkQ` isFun) + where isFun :: Type -> Bool + isFun (TyFun{}) = True + isFun _ = False + +-- | Checks to see if a type contains a type application (a b) +hasApp :: Type -> Bool +hasApp = everything (||) (False `mkQ` isApp) + where isApp :: Type -> Bool + isApp (TyApp{}) = True + isApp _ = False
+ WinDll/Version.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 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