diff --git a/Announce.txt b/Announce.txt new file mode 100644 --- /dev/null +++ b/Announce.txt @@ -0,0 +1,63 @@ +What is it? +======== + +A preprocessor and library which allow you to create dynamic libs +from arbitrary annotated Haskell programs with one click. It also +allows you to use the generated lib in C, C++ and C# just by including +the generated header files. + +At a minimum it can be considered the inverse of c2hs. + +Where to get it? +============ + +You can get it from Hackage +(http://hackage.haskell.org/package/Hs2lib) or by using cabal +(cabal install Hs2lib). + +Documentation, Mailing List, Source, etc +======================= + +Go to http://mistuke.wordpress.com/category/hs2lib/ for information. +Or for a tutorial http://www.scribd.com/doc/63918055/Hs2lib-Tutorial + +What's New? +========= + +- Currently Supported: + +* Autogerates free functions for any StablePtr used. +* Added support for memory leak tracing with the --debug flag + http://mistuke.wordpress.com/2011/08/09/tracing-lexer-memory-leaks/ +* Fixed a bug in the library that caused an error in marshalling +* No longer frees strings, in order to prevent heap corruptions on + calls from c# +* Fixed an issue with lists and type synonyms +* Fixed an alignment issue with stdcall +* Renamed the hs2c# pragma to hs2cs +* Fixed an error in parsing pragmas +* Fixed a majot marshalling bug having to do with lists of pointer types +* Started on an implementation of an automatic test generator to test + exported functions. +* Re-arranged the namespaces generated in C#. Now Functions and types are + put in different namespaces. + +- Not Currently supported: + +* Infix constructors +* Control over the autogenerated free functions for StablePtr +* Exporting of type/functions with the same name in different modules +* Exporting polymorphic functions + +Details +===== + +A more detailed documentation will follow in the next few weeks. + +Why is the first version 0.4.8? +-------------- + +This project has been in development for a very long time. Nearly two +years on and off. +It was developed mainly to facilitate the creation of Visual Haskell +2010. This is just the first public release of this tool. diff --git a/FFI.hs b/FFI.hs new file mode 100644 --- /dev/null +++ b/FFI.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +import Control.Applicative +import Control.Monad +import Foreign.C +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Array + +class Context t where + type Collapse t :: * + type Cxt t :: * -> * + collapse :: t -> Collapse t + +newtype PureCxt a = PureCxt { unwrapPure :: a } + +instance Functor PureCxt where + fmap f = PureCxt . f . unwrapPure +instance Applicative PureCxt where + pure = PureCxt + (<*>) = \(PureCxt f) (PureCxt x) -> PureCxt (f x) +instance Monad PureCxt where + return = pure + m >>= k = k $ unwrapPure m + +-- strip out pure contexts, only needs to look at one layer +instance Context (PureCxt a) where + type Collapse (PureCxt a) = a + type Cxt (PureCxt a) = PureCxt + collapse = unwrapPure + +-- merge IO contexts using join +instance Context (IO (IO a)) where + type Collapse (IO (IO a)) = IO a + type Cxt (IO (IO a)) = IO + collapse = join + +-- remove contexts underneath IO... this might need to be recursive. haven't +-- thought through all the ways contexts can stack up yet. +instance Context (IO (PureCxt a)) where + type Collapse (IO (PureCxt a)) = IO a + type Cxt (IO (PureCxt a)) = IO + collapse = fmap unwrapPure + +-- defer IO on a function to only the result. definitely recursive here. +instance (Context (IO b)) => Context (IO (a -> b)) where + type Collapse (IO (a -> b)) = a -> Collapse (IO b) + type Cxt (IO (a -> b)) = IO + collapse x y = collapse $ fmap ($ y) x + +-- should probably rethink to what extent I want to separate these... +type family ForeignCxt int :: * -> * + +type instance ForeignCxt () = PureCxt + +class Convert ext int | ext -> int, int -> ext where + type Foreign int :: * + type Native ext :: * + toForeign :: Native ext -> ForeignCxt (Native ext) (Foreign int) + toNative :: Foreign int -> ForeignCxt (Foreign int) (Native ext) + +instance Convert () () where + type Foreign () = () + type Native () = () + toForeign = pure + toNative = pure + +type instance ForeignCxt Int = PureCxt +type instance ForeignCxt CInt = PureCxt +instance Convert CInt Int where + type Foreign Int = CInt + type Native CInt = Int + toForeign = pure . fromIntegral + toNative = pure . fromIntegral + +type instance ForeignCxt Double = PureCxt +type instance ForeignCxt CDouble = PureCxt +instance Convert CDouble Double where + type Foreign Double = CDouble + type Native CDouble = Double + toForeign = pure . realToFrac + toNative = pure . realToFrac + +type instance ForeignCxt Float = PureCxt +type instance ForeignCxt CFloat = PureCxt +instance Convert CFloat Float where + type Foreign Float = CFloat + type Native CFloat = Float + toForeign = pure . realToFrac + toNative = pure . realToFrac + + +type instance ForeignCxt String = IO +type instance ForeignCxt CWString = IO +instance Convert CWString String where + type Foreign String = CWString + type Native CWString = String + toForeign = newCWString + toNative = peekCWString + +-- a quick and dirty way to represent arrays; the Int is because we need a size +-- to convert from an array, and the newtype is because otherwise instances +-- for [a] would overlap with String (which is actually [Char]) +-- it would probably be nice to handle the (Int,_) as a context, actually, +-- but I'm not sure what the most effective way to do that would be. +type SizedArray a = (Int, Ptr a) +newtype AsArray a = AsArray { getSizedArray :: [a] } +-- instance Newtype (AsArray a) [a] where + -- pack = AsArray + -- unpack = getSizedArray + +type instance ForeignCxt (AsArray a) = IO +type instance ForeignCxt (SizedArray a) = IO +instance (Storable a) => Convert (SizedArray a) (AsArray a) where + type Foreign (AsArray a) = (SizedArray a) + type Native (SizedArray a) = (AsArray a) + toForeign xs = let xs' = getSizedArray xs in (,) (length xs') <$> newArray xs' + toNative = fmap AsArray . uncurry peekArray + +class FFImport ext where + type Import ext :: * + ffImport :: ext -> Import ext + +class FFExport int where + type Export int :: * + ffExport :: int -> Export int + +class A a where + type Res a :: * + foo :: a -> Res a + +instance A Int where + type Res Int = Int + foo x = x + 4 + +-- instance ( Context (IO (ForeignCxt a (Native a))) + -- , Convert a (Native a) + -- ) => FFImport (IO a) where + -- type Import (IO a) = Collapse (IO (ForeignCxt a (Native a))) + -- ffImport x = collapse $ toNative <$> x + +-- instance ( FFImport b, Convert a (Native a) + -- , Context (ForeignCxt (Native a) (Import b)) + -- , Functor (ForeignCxt (Native a)) + -- ) => FFImport (a -> b) where + -- type Import (a -> b) = Native a -> Collapse (ForeignCxt (Native a) (Import b)) + -- ffImport f x = collapse $ ffImport . f <$> toForeign x + +-- instance ( Context (IO (ForeignCxt a (Foreign a))) + -- , Convert (Foreign a) a + -- ) => FFExport (IO a) where + -- type Export (IO a) = Collapse (IO (ForeignCxt a (Foreign a))) + -- ffExport x = collapse $ toForeign <$> x + +-- instance ( FFExport b, Convert (Foreign a) a + -- , Context (ForeignCxt (Foreign a) (Export b)) + -- , Functor (ForeignCxt (Foreign a)) + -- ) => FFExport (a -> b) where + -- type Export (a -> b) = Foreign a -> Collapse (ForeignCxt (Foreign a) (Export b)) + -- ffExport f x = collapse $ ffExport . f <$> toNative x + +-- instance ( FFImport (a -> b) + -- , FFExport (c -> d) + -- , Context (Native a -> Collapse (ForeignCxt (Native a) (Import b))) + -- ) => Convert (a -> b) (c -> d) where + -- type Native (a -> b) = Import (a -> b) + -- type Foreign (c -> d) = Export (c -> d) + -- toNative = collapse . ffImport diff --git a/Hs2lib-debug.hs b/Hs2lib-debug.hs --- a/Hs2lib-debug.hs +++ b/Hs2lib-debug.hs @@ -2,7 +2,7 @@ -- | -- Module : Windll -- Copyright : (c) Tamar Christina 2009 - 2010 --- License : GPL +-- License : BSD3 -- -- Maintainer : tamar@zhox.com -- Stability : experimental diff --git a/Hs2lib.cabal b/Hs2lib.cabal --- a/Hs2lib.cabal +++ b/Hs2lib.cabal @@ -1,11 +1,11 @@ Name: Hs2lib -Version: 0.5.6 +Version: 0.5.7 Cabal-Version: >= 1.10 Build-Type: Custom License: BSD3 License-File: LICENSE.txt -Author: Tamar Christina -Maintainer: Tamar Christina +Author: Tamar Christina +Maintainer: Tamar Christina Homepage: http://blog.zhox.com/category/hs2lib/ Category: Development Stability: experimental @@ -20,6 +20,8 @@ . Current Restrictions: . + - Does NOT support x64 bit versions of GHC. This will be added in future versions if enough demand exist. + . - 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. @@ -46,7 +48,7 @@ Includes/WinDllSupport.h -Tested-With: GHC >= 6.12 && < 7.3 +Tested-With: GHC >= 6.12 && < 7.7 Build-Depends: base >= 4, syb >= 0.1.0.2 @@ -92,10 +94,10 @@ WinDll.Lib.Tuples_Debug, WinDll.Structs.Types - Build-Depends: haskell-src-exts >= 1.9.0, + Build-Depends: haskell-src-exts >= 1.13.5, ghc >= 6.12 && < 7.0 || >= 7.0.2, base >= 4 && < 5, - filepath >= 1 && < 1.3, + filepath >= 1.1.0.2, old-locale >= 1.0.0.2, time >= 1.2.0.3, directory >= 1.0.0.3, @@ -125,7 +127,7 @@ mtl >= 1.1.0.2, containers >= 0.2.0.0, array >= 0.2.0.0, - haskell-src-exts >= 1.9.0, + haskell-src-exts >= 1.13.5, haddock >= 2.7.2, base >= 4 && < 5, syb >= 0.1.0.2, @@ -155,7 +157,7 @@ mtl >= 1.1.0.2, containers >= 0.2.0.0, array >= 0.2.0.0, - haskell-src-exts >= 1.9.0, + haskell-src-exts >= 1.13.5, haddock >= 2.7.2, base >= 4 && < 5, syb >= 0.1.0.2, @@ -187,7 +189,7 @@ mtl >= 1.1.0.2, containers >= 0.2.0.0, array >= 0.2.0.0, - haskell-src-exts >= 1.9.0, + haskell-src-exts >= 1.13.5, haddock >= 2.7.2, base >= 4 && < 5, syb >= 0.1.0.2, diff --git a/Hs2lib.hs b/Hs2lib.hs --- a/Hs2lib.hs +++ b/Hs2lib.hs @@ -2,7 +2,7 @@ -- | -- Module : Windll -- Copyright : (c) Tamar Christina 2009 - 2010 --- License : GPL +-- License : BSD3 -- -- Maintainer : tamar@zhox.com -- Stability : experimental diff --git a/LIMITS.txt b/LIMITS.txt --- a/LIMITS.txt +++ b/LIMITS.txt @@ -1,7 +1,12 @@ +Version 0.5.7 + - Added support for the newer GHC's 7.6.x + - Improved Linux support + - 64bit compatibility started + Version 0.5.6 - - Improved Linux compatibilies + - Improved Linux compatibility - Added 64bit support - - Fixed an issue with typesynonyms and how they are expanded + - Fixed an issue with type synonyms and how they are expanded - Fixed an issue with the dependency tracker in that it shouldn't care about types in a StablePtr. This is not yet fully fixed however. - Various other small changes @@ -30,8 +35,8 @@ Version 0.5.0 - Added support for memory leak tracing with the --debug flag - % Added support for qualified importing. It is now possible to export - values and types with the same name. (unfinished) + % - Added support for qualified importing. It is now possible to export + values and types with the same name. (unfinished) % - Added the ability to export polymorphic types. (unfinished) % - Added support for infix constructors (unfinished) - Generates free functions StablePtr diff --git a/TODO.txt b/TODO.txt new file mode 100644 --- /dev/null +++ b/TODO.txt @@ -0,0 +1,15 @@ +** fix http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html (includes, include-install and fix the libpaths so the files are found at runtime) + +** fix unix code compile + +** fix selecPreTyp selection error (unit test: cabal file) +** fix qualified names used in original source file +** fix the type synonym resolver. It's really buggy and needs complete rewrite +** fix Storable error with embedded structues e.g. (Maybe [String]) doesn't work inside a data declare. + -- data Foo = Foo (Maybe [String]) (Maybe (Int,[String])) +** fixed type applications with typles e.g type Field a = (Int, [a]) and Field (String, String) +** Find the bug in the c# codegen for tuples +** update type to IO +** change codegens ** partually +** change where it detects lists, IO is now supported +** test something ending in IO [] diff --git a/Templates/.svn/all-wcprops b/Templates/.svn/all-wcprops new file mode 100644 --- /dev/null +++ b/Templates/.svn/all-wcprops @@ -0,0 +1,5 @@ +K 25 +svn:wc:ra_dav:version-url +V 46 +/svn/WinDll/!svn/ver/37/trunk/WinDLL/Templates +END diff --git a/Templates/.svn/dir-prop-base b/Templates/.svn/dir-prop-base new file mode 100644 --- /dev/null +++ b/Templates/.svn/dir-prop-base @@ -0,0 +1,14 @@ +K 10 +svn:ignore +V 52 +*.hi +*.aux +*.blg +*.out +*.log +*.gz +*.idx +*.toc +*.bbl + +END diff --git a/Templates/.svn/entries b/Templates/.svn/entries new file mode 100644 --- /dev/null +++ b/Templates/.svn/entries @@ -0,0 +1,164 @@ +10 + +dir +52 +https://svn.zhox.com:3690/svn/WinDll/trunk/WinDLL/Templates +https://svn.zhox.com:3690/svn/WinDll + + + +2011-05-19T19:13:35.523032Z +37 +Phyx +has-props + + + + + + + + + + + + + +73766c1b-e474-454a-a9e1-e490cd0c8aae + +main.template-unix.c +file + + + + +2010-03-15T21:24:21.372005Z +48af026cf6e2f6f682e78360f0cdced1 +2010-03-16T03:01:07.297910Z +26 +Phyx + + + + + + + + + + + + + + + + + + + + + +568 + +nomain.template-win.c +file + + + + +2010-12-23T14:42:20.271212Z +72a799eec8f13f10992c6f1456c6320b +2011-04-10T16:33:09.493305Z +31 +Phyx + + + + + + + + + + + + + + + + + + + + + +415 + +main.template-win.c +file + + + + +2009-12-28T13:02:40.000000Z +ea42dcc8177275209a57ca29aaf11901 +2010-01-13T00:31:41.317428Z +18 +Phyx + + + + + + + + + + + + + + + + + + + + + +486 + +nomain.template-unix.c +file + + + + +2010-12-23T14:42:40.732382Z +b1be51667a0006cbeb60ffbf5916aae4 +2011-04-10T16:33:09.493305Z +31 +Phyx + + + + + + + + + + + + + + + + + + + + + +373 + diff --git a/Templates/.svn/text-base/main.template-unix.c.svn-base b/Templates/.svn/text-base/main.template-unix.c.svn-base new file mode 100644 --- /dev/null +++ b/Templates/.svn/text-base/main.template-unix.c.svn-base @@ -0,0 +1,26 @@ +#include + +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(); +} diff --git a/Templates/.svn/text-base/main.template-win.c.svn-base b/Templates/.svn/text-base/main.template-win.c.svn-base new file mode 100644 --- /dev/null +++ b/Templates/.svn/text-base/main.template-win.c.svn-base @@ -0,0 +1,23 @@ +#include +#include + +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; +} + diff --git a/Templates/.svn/text-base/nomain.template-unix.c.svn-base b/Templates/.svn/text-base/nomain.template-unix.c.svn-base new file mode 100644 --- /dev/null +++ b/Templates/.svn/text-base/nomain.template-unix.c.svn-base @@ -0,0 +1,21 @@ +#include + +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(); +} diff --git a/Templates/.svn/text-base/nomain.template-win.c.svn-base b/Templates/.svn/text-base/nomain.template-win.c.svn-base new file mode 100644 --- /dev/null +++ b/Templates/.svn/text-base/nomain.template-win.c.svn-base @@ -0,0 +1,22 @@ +#include +#include + +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(); +} diff --git a/Templates/nomain.template-win.c b/Templates/nomain.template-win.c --- a/Templates/nomain.template-win.c +++ b/Templates/nomain.template-win.c @@ -3,7 +3,7 @@ extern void __stginit_%name(void); -void %callconv HsStart(void) +void __declspec(dllexport) __%callconv HsStart(void) { int argc = 1; char* argv[] = {"ghcDll", NULL}; // argv must end with NULL @@ -16,7 +16,7 @@ hs_add_root(__stginit_%name); } -void %callconv HsEnd(void) +void __declspec(dllexport) __%callconv HsEnd(void) { hs_exit(); } diff --git a/Tests/Exec/Analyze.hs b/Tests/Exec/Analyze.hs --- a/Tests/Exec/Analyze.hs +++ b/Tests/Exec/Analyze.hs @@ -18,10 +18,65 @@ import WinDll.Identifier import WinDll.Utils.Feedback import WinDll.Session.Hs2lib +import WinDll.Structs.Structures +import Data.Monoid + import Tests.Exec.Structs +-- | Measure the costs of the datatypes of modules and +-- create the generator functions for these types. analyzeModule :: Exec [Arbitrary] analyzeModule = do modinfo <- generateMain - return [] + let (normal, special) = modDatatypes modinfo + values = normal `mappend` special + datatypes <- mapM (measureCost values) values + + mapM (liftIO . print) datatypes + + return datatypes + +-- | Measure the costs of the datatype's constructor +-- so we know how to generate instances of the datatype +measureCost :: DataTypes -> DataType -> Exec Arbitrary +measureCost lst dtype + = do let atype x = Arbitrary { arName = dtName dtype + , arVars = dtVars dtype + , arCons = x + , arCosts = (0,0) + , arTag = dtTag dtype + } + consts = getConstructors dtype + + arbs <- mapM (getConCost lst) consts + + let costs = getTypeCosts arbs + + return $ (atype arbs){arCosts = costs} + +-- | Get the minimum and maximum costs of a type by looking at the +-- costs of the constructors of the type. +getTypeCosts :: Arbitraries -> (Int, Int) +getTypeCosts [] = (0,0) +getTypeCosts ((v@Variant{}):xs) = let cost = arCost v + (minCost, maxCost) = getTypeCosts xs + in (minCost `min` cost, maxCost `max` cost) +getTypeCosts _ = (0,0) + +-- | returns the constructors of a type +getConstructors :: DataType -> DataTypes +getConstructors (DataType _ _ x _) = x +getConstructors (NewType _ _ x _) = [x] +getConstructors (x@Constr{}) = [x] + +-- | Get the cost of the constructors. +getConCost :: DataTypes -> DataType -> Exec Arbitrary +getConCost lst (Constr n f ann) + = do let var = Variant { arCost = 0 + , arName = n + , arFix = f + , arNamed = [] + } + return var +getConCost _ _ = die "getConCost can only determine the cost of constructors. try 'measureCost' instead" diff --git a/Tests/Exec/Example.hs b/Tests/Exec/Example.hs --- a/Tests/Exec/Example.hs +++ b/Tests/Exec/Example.hs @@ -13,7 +13,7 @@ | Var String | Let String Expr Expr --- @@ Expr +-- @@ Export printExpr :: Expr -> String printExpr (Mul e1 e2) = printExpr e1 ++ " * " ++ printExpr e2 printExpr (Div e1 e2) = printExpr e1 ++ " / " ++ printExpr e2 diff --git a/Tests/Exec/Hs2lib-testgen.hs b/Tests/Exec/Hs2lib-testgen.hs --- a/Tests/Exec/Hs2lib-testgen.hs +++ b/Tests/Exec/Hs2lib-testgen.hs @@ -51,7 +51,7 @@ -- These lines do all the needed calculations - traceDeps -- Read all dependencies, so we find the tree of files which need parsing + 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 diff --git a/Tests/Exec/Structs.hs b/Tests/Exec/Structs.hs --- a/Tests/Exec/Structs.hs +++ b/Tests/Exec/Structs.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Windll @@ -20,11 +21,14 @@ import Data.Data import Data.Typeable +type Arbitraries = [Arbitrary] + -- | A Extended version of \Datatype\ to support weighing of -- constructors etc. -data Arbitrary = Arbitrary { arName :: Name +data Arbitrary = Arbitrary { arCosts :: (Int, Int) + , arName :: Name , arVars :: [TypeName] - , arCons :: DataTypes + , arCons :: Arbitraries , arTag :: TypeTag } | Variant { arCost :: Int @@ -40,3 +44,7 @@ , awtType :: AnnType } deriving(Eq,Data,Typeable) + +deriving instance Show DataFixity +deriving instance Show Arbitrary +deriving instance Show AnnWeighedType diff --git a/WinDll/Debug/Output.hs b/WinDll/Debug/Output.hs --- a/WinDll/Debug/Output.hs +++ b/WinDll/Debug/Output.hs @@ -48,7 +48,7 @@ data MemResult = MemResult { memHeap :: Heap - , memRSize :: Int + , memRSize :: Int , memOuts :: [Outstanding] , memUnAlloc :: Int } @@ -71,7 +71,7 @@ outdat = map (\x -> guard (not $ null x) >> (return $ Outs (length x) (snd $ head x) (map fst x))) merged put $ session { memAllocs =[], memAllocsLen = 0, heap = hp } return $ MemResult { memHeap = hp - , memRSize = size + , memRSize = size , memUnAlloc = outst , memOuts = catMaybes outdat } diff --git a/WinDll/Debug/Stack.xhs b/WinDll/Debug/Stack.xhs --- a/WinDll/Debug/Stack.xhs +++ b/WinDll/Debug/Stack.xhs @@ -60,7 +60,7 @@ -- | Pretty print a stack back out to a string printStack :: Stack -> String printStack Empty = [] -printStack (Then fn s) = printStack s ";" fn ";" +printStack (Then fn s) = printStack s "\n\t\t" fn printStack (Combined s1 s2) = printStack s2 printStack s1 printStack (Recursed s1 s2) = printStack s2 printStack s1 "..." diff --git a/WinDll/EntryPoint.hs b/WinDll/EntryPoint.hs --- a/WinDll/EntryPoint.hs +++ b/WinDll/EntryPoint.hs @@ -70,10 +70,8 @@ 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)) + let callconv = call session -- This needs to check for OS bit, in windows x64 there is only one calling convention + let adj = strReplace "%callconv" (map toLower (genCcall $ callconv)) . strReplace "%name" name let newfile = adj file diff --git a/WinDll/Identifier.hs b/WinDll/Identifier.hs --- a/WinDll/Identifier.hs +++ b/WinDll/Identifier.hs @@ -85,7 +85,9 @@ defs <- makeSessionAnn let mexports = exports merged ++ generateFreeExports mstableptr - mstableptr = (nubBy ((==) `on` stType) $ findStableRefs d ++ findStableRefs f ) + expandedTy = resolveTypeSyn t + stables = findStableRefs expandedTy d ++ findStableRefs expandedTy f + mstableptr = nubBy ((==) `on` stType) stables calls1 <- generateCallbacksFromExports defs mexports calls2 <- mapM (genCallbacksFromDatatype defs) d @@ -198,15 +200,21 @@ in return result -- | 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] +findStableRefs :: (Data r, Typeable r) => [TypeDecL] -> r -> [Stable] +findStableRefs tyL x = let list = listify isRef x + vals = nub $ map simplify list + dats = simplify vals + nms = map flattenToString dats + in [Stable ("free"++ getName x y tyL) y [] | x <- nms, y <- dats] where isRef (Exts.TyApp x y) | mshowM 2 x == "StablePtr" = True isRef _ = False + + getName base ty synL = let match = filter (==ty) . map repTypes $ synL + -- this is not working.. need to check why + in if null match then strip base else typeName (head synL) + + strip = filter isAlphaNum -- | Generate free functions for stable ptrs found. generateFreeFuncs :: [Stable] -> [Function] @@ -290,7 +298,35 @@ in if changed then fixpoint m' else everywhere (mkT (simplify :: Type -> Type)) m' -- correct types - + +------------------------------------------------------------------------------ +-- | Uses a fixpoint iteration to expand a type synonym to the maximum expanded +-- type that can be made from it: +-- +-- For example: +-- +-- type Session = Interpreter () +-- type Context = StablePtr (IORef Session) +-- +-- turns into: +-- +-- type Session = Interpreter () +-- type Context = StablePtr (IORef (Interpreter ())) +------------------------------------------------------------------------------ +resolveTypeSyn :: [TypeDecL] -> [TypeDecL] +resolveTypeSyn 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 t + changed = t/=m' + apply = flip (foldr ($)) + in if changed + then resolveTypeSyn m' + else everywhere (mkT (simplify :: Type -> Type)) m' -- correct types + ------------------------------------------------------------------------------ -- | This is a hack to get a working first version. It basically merges all -- module declaration, which introduces various restrictions on the first diff --git a/WinDll/Parsers/Hs2lib.bak b/WinDll/Parsers/Hs2lib.bak new file mode 100644 --- /dev/null +++ b/WinDll/Parsers/Hs2lib.bak @@ -0,0 +1,586 @@ + {-# LANGUAGE RelaxedPolyRec #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Parsers for the preprocessor. Parses using Haskell-src-exts +-- to the simple datatype in \WinDll.Structs.Structures\ +-- These parsers are for the main program +-- +----------------------------------------------------------------------------- + +module WinDll.Parsers.Hs2lib where + +import Language.Haskell.Exts +import Language.Haskell.Exts.Extension +import qualified Language.Haskell.Exts as Exts +import Language.Haskell.Exts.Parser +import Language.Haskell.Exts.Syntax +import Language.Haskell.Exts.SrcLoc +import Language.Haskell.Exts.Comments + +import Data.Generics + +import Data.IORef + +import Data.List +import Data.Char +import Data.Maybe + +import System.IO.Unsafe +import System.FilePath +import System.Directory + +import Control.Monad + +import WinDll.Structs.Structures hiding (Module) +import qualified WinDll.Structs.Structures as WinDll +import WinDll.Session.Hs2lib +import WinDll.Version.Hs2lib +import WinDll.Utils.Feedback +import WinDll.Structs.PrettyPrinting +import WinDll.Structs.MShow.HaskellSrcExts +import WinDll.Structs.MShow.MShow +import WinDll.Structs.Folds.HaskellSrcExts +import WinDll.Utils.Types + +import qualified Debug.Trace as D + +-- testFile = "C:\\Users\\Phyx\\Documents\\Haskell\\WinDLL\\test.hs" +testFile = "C:\\Users\\Phyx\\Documents\\Desktop\\native\\GHCDll.hs" + +instance Num SrcLoc where + (SrcLoc f l1 c1) - (SrcLoc _ l2 c2) = SrcLoc f (l1-l2) (c1-c2) + (SrcLoc f l1 c1) + (SrcLoc _ l2 c2) = SrcLoc f (l1+l2) (c1+c2) + (SrcLoc f l1 c1) * (SrcLoc _ l2 c2) = SrcLoc f (l1*l2) (c1*c2) + abs (SrcLoc f l c) = SrcLoc f (abs l) (abs c) + signum (SrcLoc f l c) = SrcLoc f (signum l) (signum c) + fromInteger i = SrcLoc [] (fromInteger i) 0 + +-- instance Ord Decl where + -- compare a b = if (a == b) then EQ else LT + +-- | Read a file in, And store it in the list of \WinDll.Module\ and \WinDll.CodeGen.CommentDecl\ +readFromFiles :: Exec () +readFromFiles = + do session <- get + inform _normal "Reading and parsing all dependencies..." + let workset = workingset session + paths <- liftIO $ mapM guessPath ((drop 1 (dependencies workset))++includes session) + (result, c0) <- liftM unzip $ forM (absPath session : paths) pdata + put $ session { workingset = workset { modules = result + , pragmas = catMaybes (parseComments (join c0)) } } + where pdata :: FilePath -> Exec ((WinDll.Module, [CommentDecl]),[Comment]) + pdata path = + do (m0,c0) <- parseFromFile path + inform _detail "Converting AST to internal representation..." + moddata' <- convertModule m0 c0 + inform _detail "Updating module name..." + let moddata = moddata' { header = (header moddata') { headername = reverse $ drop 1 $ dropWhile (/='.') $ reverse $ takeFileName path } } + inform _detail "Matching and resolving comments..." + let modcomment = matchFunctionsWithComments c0 (findTypeSignatures m0) + inform _detail ("Finished processing " ++ path ++ "...\n") + return ((moddata,modcomment), c0) + + fixDependencies :: String -> FilePath + fixDependencies current = let ldata = map (\a-> if a == '.' then pathSeparator else a) current + fdata = ldata++".hs" + in case unsafePerformIO (doesFileExist fdata) of + True -> fdata + False -> ldata ++ ".lhs" + +-- | Convert the right comments to the correct pragmas. These are all globally scoped. +-- . +-- . supported pragmas are: +-- . {- @@ HS2LIB_OPTS @@ -} -=- turn on dynamic options present in this file +-- . {- @@ INSTANCE @@ -} -=- generate type info required to work correctly but also hides the warning of missing data definition +-- . {- @@ IMPORT @@ -} -=- Imports to carry over to the new generated module +-- . {- @@ HS2C @ @@ -} -=- Specifies what to translate the Haskell htype to the C type, but we also need its size in bytes +-- . {- @@ HS2CS @@ -} -=- Specifies what to translate the Haskell htype to the C# type, but we also need its size in bytes +-- . {- @@ HS2HS @@ -} -=- 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` +-- . {- @@ LANGUAGE [Pragmas] @@ -} -=- Enable these pragmas in the generated source code. +-- . +parseComments :: [Comment] -> [Maybe Pragma] +parseComments [] = [] +parseComments ((Comment True _ s):xs) = f (trim s): parseComments xs + where f :: String -> Maybe Pragma + f s | "@@ " `isPrefixOf` s && " @@" `isSuffixOf` s = let stack = trim (drop 3 (take (length s - 3) s)) + (x:xs) = lexwords stack + name = (map toUpper x) + xs' = if name == (upper_name ++"_OPTS") then tail $ words stack else xs + in if null stack then Nothing else Just (Pragma name xs') + | otherwise = Nothing + + trim :: String -> String + trim = reverse . dropWhile (==' ') . reverse . dropWhile (==' ') +parseComments (_ :xs) = parseComments xs + +lexwords :: String -> [String] +lexwords [] = [] +lexwords str = let res = lex str + (cur,rest) = head res + cur' = case cur of + [] -> [] + '"':xs -> init xs : lexwords rest + '-':_ -> let other = lexwords rest + (x:xs) = other + in if null other then cur : other else (cur++x) : xs + x -> x : lexwords rest + in if null res then [] else cur' + +-- | Parse a module from file while retaining comments +parseFromFile :: FilePath -> Exec (Module, [Comment]) +parseFromFile path = + do inform _detail ("Parsing '" ++ path ++ "'") + result <- liftIO $ parseFileWithComments (defaultParseMode { extensions = (TemplateHaskell:BangPatterns:NamedFieldPuns:ExplicitForall:glasgowExts), parseFilename = path }) path + case result of + (ParseOk a) -> return a + (ParseFailed loc str) -> die (exename ++ " parse failure, reason: " ++ str ++ " at " ++ show loc) + +-- | Finds all the type declarations from a given file. +findTypeSignatures :: Module -> [Decl] +findTypeSignatures = listify inner + where inner (TypeSig _ _ _) = True + inner _ = False + +-- | Finds all the type synonym declarations from a given file. +findTypeDecl :: Module -> [Decl] +findTypeDecl = listify inner + where inner (TypeDecl _ _ _ _) = True + inner _ = False + +-- | Finds all the foreign export declarations in a file +findForeignExports :: Module -> [Decl] +findForeignExports = listify inner + where inner (ForExp _ _ _ _ _) = True + inner _ = False + +-- | Finds all the newtype or data declarations withing the given structure +findDataDeclarations :: Module -> [Decl] +findDataDeclarations = listify inner + where inner (DataDecl _ _ _ _ _ _ _) = True + inner _ = False + +-- | Finds all the Storable instances declarations +findStorableDeclarations :: Module -> [Decl] +findStorableDeclarations = listify inner + where inner (InstDecl _ _ name _ _ ) = "Storable" `elem` (findStrings name) + inner _ = False + +-- | Match function and comments to eachother and determine which comments indicate out special -- \@\@ comment flag +matchFunctionsWithComments :: [Comment] -> [Decl] -> [CommentDecl] +matchFunctionsWithComments comments decls = + let directives = filter (\t->"@@" `isPrefixOf` strip (readComment t)) comments + in merge $ catMaybes $ map (matchDecl decls) (map convertComment directives) + where readComment :: Comment -> String + readComment (Comment _ _ s) = s + + convertComment :: Comment -> MyComment + convertComment (Comment _ l s) = MyComment l s + + strip :: String -> String + strip = dropWhile isSpace + + maxScore :: Int + maxScore = 500 + + getScore :: SrcLoc -> Int + getScore (SrcLoc _ l f) = if l > 0 then l else maxScore -- l*l + f*f + + convertLoc :: SrcSpan -> SrcLoc + convertLoc (SrcSpan n l f _ _) = SrcLoc n l f + + matchDecl :: [Decl] -> MyComment -> Maybe CommentDecl + matchDecl decls (MyComment l s) = + let ordered = sort $ map (\t@(TypeSig d _ _)->(getScore (d- (convertLoc l)),([s],t))) decls + value = head ordered + score = fst value + in if score < maxScore then Just (snd value) else Nothing + + merge :: [CommentDecl] -> [CommentDecl] + merge [] = [] + merge x = map (foldr1 (\(a,_) (b,f)->(a++b,f))) $ groupBy (\a b->snd a==snd b) x + +-- | Standard imports list for all generated moduels +stdImports :: Exec [Import] +stdImports = do session <- get + let db = debugging session + return $ [ if db + then "WinDll.Lib.NativeMapping_Debug" + else "WinDll.Lib.NativeMapping" + ,if db + then "WinDll.Lib.Tuples_Debug" + else "WinDll.Lib.Tuples" + ,"WinDll.Lib.InstancesTypes" + ,if db + then "Foreign hiding (free, malloc, alloca, realloc)" + else "Foreign" + ,"Foreign.C" + ,"Foreign.C.Types" + ,"Foreign.Ptr" + ,if db + then "WinDll.Debug.Alloc" + else "Foreign.Marshal.Alloc" + ,"Foreign.Marshal.Utils" + ,"Foreign.ForeignPtr" + ] ++ if db + then ["WinDll.Debug.Stack" + ,"qualified WinDll.Debug.Exports as Ex" + ] + else [] + +-- | Convert the parsed Haskell-src-exts to the internal Module definition. +-- A nother limitation to get this done on time, is that i don't support infix constructors +convertModule :: Module -> [Comment] -> Exec WinDll.Module +convertModule m@(Module (SrcLoc file _ _) (ModuleName modname) _ _ _ _ decl) comments = + let header = Header modname [] + exports = map createExport t_func + datatypes = map createDataType t_data + functions = map createFunction t_func + tdecl = map createTypeSyn t_type + instances = map createInstance t_inst + foreigns = map createForeign t_fexpr + + t_func = filter isExport $ fixC $ matchFunctionsWithComments comments (findTypeSignatures m) + t_data = findDataDeclarations m + t_type = findTypeDecl m + t_inst = findStorableDeclarations m + t_fexpr = findForeignExports m + + in do session <- get + let workset = workingset session + newset = workset { n_exports = n_exports workset ++ foreigns } + newsess = session { workingset = newset } + put newsess + stdi <- stdImports + return $ WinDll.Module header file (("@"++modname):stdi) exports datatypes functions instances tdecl + where isExport :: CommentDecl -> Bool + isExport (flags, _) = any (isPrefixOf "export") (map (map toLower) flags) + + strip :: String -> String + strip = dropWhile isSpace + + prep :: String -> String + prep = strip . drop 2 . strip + + fixC :: [CommentDecl] -> [CommentDecl] + fixC = map (\(c,d)->(map prep c,d)) + + createFunction :: CommentDecl -> Function + createFunction (p,(TypeSig _ name' typ')) = Function name (tlength typ - 1) ty ann typ + where args = findStrings typ + t_name = head $ findStrings name' + typ = simplify typ' + (ann ,ty) = upgradeType newAnn typ + export = strip $ drop 6 $ head' $ filter ((=="export").map toLower.takeWhile (not.(\a->isSpace a || a=='='))) p + name = t_name + + createForeign :: Decl -> HaskellExport + createForeign (ForExp _ cc _ name ty) = HaskellExport (convert cc) newAnn (Export name' name' typ typ modname) + where convert Exts.StdCall = WinDll.Session.Hs2lib.StdCall + convert Exts.CCall = WinDll.Session.Hs2lib.CCall + + typ = simplify ty + name' = mkName name + + mkName (Exts.Ident s) = s + mkName (Exts.Symbol s) = s + + createExport :: CommentDecl -> Export + createExport (p,(TypeSig _ name' _type)) = Export name exportn ty typ modname + where t_name = head $ findStrings name' + (_ ,ty) = upgradeType newAnn typ + typ = simplify _type + export = strip $ drop 6 $ head' $ filter ((=="export").map toLower.takeWhile (not.(\a->isSpace a || a=='='))) p + exportn = if ("=" `isPrefixOf` export) then (takeWhile (not.isSpace).strip.tail) export else name + name = t_name + + head' :: [[a]] -> [a] + head' [] = [] + head' (x:xs) = x + + newAnn = noAnn { annModule = modname } + + createTypeSyn :: Decl -> WinDll.TypeDecL + createTypeSyn (TypeDecl _ name bind typ) = TypeDecL (head $ findStrings name) + (findStrings bind) (simplify typ) + + createDataType :: Decl -> WinDll.DataType + createDataType (DataDecl _ Exts.DataType _ name types constr _) = WinDll.DataType (head $ findStrings name) (findStrings types) (map (mkConstr (head $ findStrings name)) constr) NoTag + createDataType (DataDecl _ Exts.NewType _ name types constr _) = WinDll.NewType (head $ findStrings name) (findStrings types) (head $ map (mkConstr (head $ findStrings name)) constr) NoTag + + mkConstr str = (\(QualConDecl _ _ _ con)->case con of + (ConDecl cname vars) -> Constr xname Normal (genFreeVars modname name 1 vars) + where name = let val = map toLower (str++"_"++xname++"_var") + in (val++) + xname = (head $ findStrings cname) + (RecDecl cname vars) -> Constr (head $ findStrings cname) Normal (genNamedVars modname vars) + (InfixConDecl a name b) -> error "Parse error: Sorry, the current version of windll does not support infix constructor types.") + createInstance :: Decl -> WinDll.Instance + createInstance (InstDecl _ con name types decls) + = QualifiedInstance (head $ findStrings name) types + +-- | Generate free variable names +genFreeVars :: WinDll.ModuleName -> (String -> String) -> Int -> [BangType] -> AnnNamedTypes +genFreeVars nm f _ [] = [] +genFreeVars nm f n (x:xs) = let (ann, ty) = upgradeType noAnn t + t = getTypeFromBang x + name = (f.show) n + ann' = ann{ annArrayIsList = True, annArrayIndices = [], annModule = nm } + value = case isOnlyList t of + False -> AnnType name ty ann t nm + True -> AnnType name t ann' t nm + in value : genFreeVars nm f (n+1) xs + +-- | Strip a layer away and get to the real type. +getTypeFromBang :: BangType -> WinDll.Type +getTypeFromBang (BangedTy t) = t +getTypeFromBang (UnBangedTy t) = t +getTypeFromBang (UnpackedTy t) = t + +-- | Create elements of constructor for records. +genNamedVars :: Data b => WinDll.ModuleName -> [([b],BangType)] -> AnnNamedTypes +genNamedVars _ [] = [] +genNamedVars n (((x:_),a):xs) = let (ann,val) = upgradeType noAnn ty + ann' = ann{ annArrayIsList = True, annArrayIndices = [], annModule = n } + ty = getTypeFromBang a + name = head $ findStrings x + value = case isOnlyList ty of + False -> AnnType name val ann ty n + True -> AnnType name ty ann' ty n + in value : genNamedVars n xs + +-- | See if the type is just a list type +isOnlyList :: Exts.Type -> Bool +isOnlyList (Exts.TyParen a) = isOnlyList a +isOnlyList (Exts.TyList _) = True +isOnlyList _ = False + +-- | Find all type strings, taking care to support things like type application +findTypeString :: Language.Haskell.Exts.Syntax.Type -> [String] +findTypeString (TyForall m c t ) = findTypeString t +findTypeString (TyFun t1 t2 ) = (findTypeString t1)++(findTypeString t2) +findTypeString (TyTuple b t ) = ["(" ++ foldr1 (\a b->a++","++b) (concatMap findTypeString t) ++ ")"] +findTypeString (TyList t ) = ["[" ++ unwords (findTypeString t) ++ "]"] +findTypeString (TyApp t1 t2 ) = [unwords (findTypeString t1 ++ findTypeString t2)] +findTypeString (TyVar n ) = findStrings' n +findTypeString (TyCon q ) = findStrings' q +findTypeString (TyParen p ) = ["(" ++ foldr1 (\a b->a++" -> "++b) (findTypeString p) ++ ")"] +findTypeString (TyInfix t1 q t2) = findTypeString t1 ++ findStrings' q ++ + findTypeString t2 +findTypeString (TyKind t k ) = findTypeString t + +-- | Rename the AST to not treat SpecialCons special but just as strings +renameAST :: Data a => a -> a +renameAST = everywhere (mkT inner) + where inner :: QName -> QName + inner (Special x) = UnQual (Symbol (mshow x)) + inner x = x + +-- | Merge the specialized Type version along with the generic version +findStrings :: Data a => a -> [String] +findStrings = findStrings' -- `extQ` findTypeString).renameAST + +-- | The SYB traversals do too much work, I need to figure out how to solve this. (it applies a matching function in both cases. +mkUnique :: [String] -> [String] +mkUnique x = filter condition x + where condition y = let y' = y ++ " " + y'' = ' ':y + y''' = (' ':y) ++ " " + in not (case y of + [] -> True + (o:_) -> any (\a->y' `isPrefixOf` a || y'' `isSuffixOf` a || y''' `isInfixOf` a) x) + +-- | Upgrade a type by performing actions such as identifying list +-- and changing the type to also pass along list counters +upgradeType :: Ann -> Exts.Type -> (Ann, Exts.Type) +upgradeType ann x = + let t' = updateType True ann' t + t = simplify x + lst' = findListIndices ty' + ann' = ann{annArrayIndices = lst'} + ty' = analyzeType True t' + in (ann', ty') + +-- | Check to see if the last argument of the type is a list +-- in which case we should change the Int before it to Ptr CInt +analyzeType :: Bool -> Exts.Type -> Exts.Type +analyzeType esc t = + let t' = everywhere (mkT embedded) t + lst = findListIndices t' + arr' = tlength t' - 1 + part = arr' `elem` lst + ty' = if part + then changeType esc arr' (\val -> case val of + Exts.TyCon (Exts.UnQual (Exts.Ident "Int")) -> (Exts.TyApp + (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr") + (Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int")) + _ -> val) t' + else t' + in ty' -- D.trace ("IN: " ++ mshowM 2 t') $ D.trace ("OUT: " ++ mshowM 2 ty') $ D.trace (show arr' ++ " - " ++ show lst) ty' + where embedded :: Exts.Type -> Exts.Type + embedded (Exts.TyParen a) = (Exts.TyParen (analyzeType esc a)) + embedded x = x + +-- | Update the n-th element of the type with whatever we want +changeType :: Bool -> Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type +changeType _esc n f ty = fst $ (foldTypeIO alg ty) 0 + where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int)) + alg = (\a b c i -> let (c', i') = c i + in (Exts.TyForall a b c', i') + ,\a b i -> let (a', i' ) = a i + (b', i'') = b i' + in (Exts.TyFun a' b', i'') + ,\a b i -> let (b', i') = app b i + in (Exts.TyTuple a b', i) + ,\a i -> let (a', i') = a i + in (Exts.TyList a', i') + ,\o a b i -> let (a', i' ) = a i + (b', i'') = b i' + ix = if o then i'' else i' + in (Exts.TyApp a' b', ix) -- i'') + ,\a i -> let i' = i + 1 + a' = Exts.TyVar a + in if i' == n + then (f a', i') + else (a' , i') + ,\a i -> let i' = i + 1 + a' = Exts.TyCon a + in if i' == n + then (f a', i') + else (a' , i') + ,\a i -> let (a', i') = a i + in (Exts.TyParen a', i') + ,\a b c i -> let (a', i' ) = a i + (c', i'') = c i' + in (Exts.TyInfix a' b c', i'') + ,\a b i -> let (a', i') = a i + in (Exts.TyKind a' b, i') + ) + app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int) + app [] i = ([], i) + app (x:xs) i = let (x' , i' ) = x i + (xs', i'') = app xs i' + in (x':xs', i'') + +-- | Update a type according to the annotations present +updateType :: Bool -> Ann -> Exts.Type -> Exts.Type +updateType esc ann = everywhere (mkT pushType) + where -- | Types to update + pushType :: Exts.Type -> Exts.Type + pushType (Exts.TyFun a b) = let f x = case isIOList x of + True -> Exts.TyFun + (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int") + False -> id + g x = case isIOList x of + True -> Exts.TyFun + (Exts.TyApp + (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Ptr") + (Exts.TyCon $ Exts.UnQual $ Exts.Ident $ if esc then "CInt" else "Int")) + x + False -> x + in f a $ Exts.TyFun a (g b) + -- pushType (Exts.TyApp a b) = let f x = case isList x of + -- True -> Exts.TyFun + -- (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int") x + -- False -> x + -- in if isIO a + -- then simplify (move a $ f b) + -- else Exts.TyApp a b + pushType x = x + + -- | Move an IO declaration inwards. + move :: Exts.Type -> Exts.Type -> Exts.Type + move io (Exts.TyFun a b) = Exts.TyFun a (Exts.TyApp io b) + move io rest = Exts.TyApp io rest + + +-- | Identifies locations within a Type where lists are found +-- The indices provided are the locations of the size variables +-- of arrays. The counters start at 0 and not 1 anymore. +-- So keep this in mind :) +findListIndices :: Exts.Type -> [Int] +findListIndices ty = coords (embed ty) + where embed :: Exts.Type -> [Bool] + embed (Exts.TyFun a b) = let res = isList a + in if isFun b + then res:embed b + else res:[isIOList b] + embed (Exts.TyParen a) = embed a + embed _ = [] + + coords :: [Bool] -> [Int] + coords b = [i | (x,i) <- zip b [(-1)..], x] + +-- | A variant of isList that looks inside IO +isIOList :: Exts.Type -> Bool +isIOList (Exts.TyApp a b) = if isIO a + then isList b + else False +isIOList x = isList x + +-- | Update the n-th element of the type with whatever we want, +-- only looking at the amount of (->) constructors. +processTypeNode :: Int -> (Exts.Type -> Exts.Type) -> Exts.Type -> Exts.Type +processTypeNode n f ty = fst $ (foldTypeIO alg ty) 1 + where alg :: TypeAlgebraIO (Int -> (Exts.Type, Int)) + alg = (\a b c i -> let (c', i') = c i + in (Exts.TyForall a b c', i') + ,\a b i -> let (a', i' ) = a i + (b', i'') = b (i + 1) + value = Exts.TyFun (if i == n then f a' else a') + (if i+1 == n then f b' else b') + in (value , i'') + ,\a b i -> let (b', i') = app b i + in (Exts.TyTuple a b', i) + ,\a i -> let (a', i') = a i + in (Exts.TyList a', i') + ,\o a b i -> let (a', i' ) = a 0 + (b', i'') = b 0 + in (Exts.TyApp a' b', i) + ,\a i -> (Exts.TyVar a, i) + ,\a i -> (Exts.TyCon a, i) + ,\a i -> let (a', i') = a i + in (Exts.TyParen a', i') + ,\a b c i -> let (a', i' ) = a i + (c', i'') = c i' + in (Exts.TyInfix a' b c', i'') + ,\a b i -> let (a', i') = a i + in (Exts.TyKind a' b, i') + ) + app :: [Int -> (Exts.Type, Int)] -> Int -> ([Exts.Type], Int) + app [] i = ([], i) + app (x:xs) i = let (x' , i' ) = x i + (xs', i'') = app xs i' + in (x':xs', i'') + +-- | Updates a type to that which uses IO +mkIO :: Exts.Type -> Exts.Type +mkIO ty = let arr = tlength ty + mk = simplify . Exts.TyApp (Exts.TyCon $ Exts.UnQual $ Exts.Ident "IO") + in if isIO ty + then ty + else if arr == 1 -- if there are no arguments, just directly apply mk + then mk ty + else processTypeNode arr mk ty + +-- | Checks to see if the function being returned is in IO +isIO :: Exts.Type -> Bool +isIO ty = let tys = collectLessTypes ty + ret = last tys + in "IO" `isPrefixOf` ret + +-- simpleTest :: FilePath -> [CommentDecl] +-- simpleTest path = let (m0, c0) = unsafePerformIO $ parseFromFile path + -- in matchFunctionsWithComments c0 (findTypeSignatures m0) + +-- test :: IO WinDll.Module +-- test = fmap (uncurry convertModule) (parseFromFile testFile) diff --git a/WinDll/Parsers/Hs2lib.hs b/WinDll/Parsers/Hs2lib.hs --- a/WinDll/Parsers/Hs2lib.hs +++ b/WinDll/Parsers/Hs2lib.hs @@ -1,4 +1,5 @@ - {-# LANGUAGE RelaxedPolyRec #-} +{-# LANGUAGE RelaxedPolyRec #-} +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | @@ -140,7 +141,7 @@ 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 + 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) @@ -209,7 +210,7 @@ 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 +-- | Standard imports list for all generated modules stdImports :: Exec [Import] stdImports = do session <- get let db = debugging session @@ -220,9 +221,16 @@ then "WinDll.Lib.Tuples_Debug" else "WinDll.Lib.Tuples" ,"WinDll.Lib.InstancesTypes" - ,if db - then "Foreign hiding (free, malloc, alloca, realloc)" +#if __GLASGOW_HASKELL__ >= 702 + , "System.IO.Unsafe" + ,if db + then "Foreign hiding (free, malloc, alloca, realloc, unsafePerformIO)" + else "Foreign hiding (unsafePerformIO)" +#else + ,if db + then "Foreign hiding (free, malloc, alloca, realloc)" else "Foreign" +#endif ,"Foreign.C" ,"Foreign.C.Types" ,"Foreign.Ptr" diff --git a/WinDll/Session/Hs2lib.hs b/WinDll/Session/Hs2lib.hs --- a/WinDll/Session/Hs2lib.hs +++ b/WinDll/Session/Hs2lib.hs @@ -143,10 +143,10 @@ , 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 + , n_hs2c :: [(String, String)] -- ^ @n_hs2c@ supplementary list of conversions of Haskell to C, user provided + , n_csize :: [(String, Int )] -- ^ @n_csize@ supplementary list of C sizes, user provided + , n_hs2cs :: Bool -> [(String, String)] -- ^ @n_hs2cs@ supplementary list of conversions of Haskell to C#, user provided + , n_hs2hs :: [(String, String)] -- ^ @n_hs2hs@ supplementary list of conversions of Haskell to HSC, user provided } deriving Show diff --git a/WinDll/Structs/MShow/HaskellSrcExts.hs b/WinDll/Structs/MShow/HaskellSrcExts.hs --- a/WinDll/Structs/MShow/HaskellSrcExts.hs +++ b/WinDll/Structs/MShow/HaskellSrcExts.hs @@ -125,7 +125,7 @@ "IO" -> name ++ " (" ++ fold f b ++ ")" _ | isPrime a || "Ptr" `isSuffixOf` name -> "(" ++ name ++ " " ++ fold (not $ isList b) b ++ ")" - | otherwise -> "(" ++ name ++ " " ++ fold False b ++ ")" + | otherwise -> "(" ++ name ++ " " ++ fold True b ++ ")" fold f (Exts.TyVar a) = mshow a fold f (Exts.TyCon a) = case f of True -> mshow a diff --git a/WinDll/Utils/DepScanner.hs b/WinDll/Utils/DepScanner.hs --- a/WinDll/Utils/DepScanner.hs +++ b/WinDll/Utils/DepScanner.hs @@ -64,7 +64,9 @@ -- | Get the module dependency graph of the given file getGraph :: String -> IO ModuleGraph getGraph file = -#if __GLASGOW_HASKELL__ >= 702 +#if __GLASGOW_HASKELL__ >= 704 + defaultErrorHandler defaultFatalMessager defaultFlushOut $ do +#elif __GLASGOW_HASKELL__ >= 702 defaultErrorHandler defaultLogAction $ do #else defaultErrorHandler defaultDynFlags $ do diff --git a/WinDll/Utils/Processes.hs b/WinDll/Utils/Processes.hs --- a/WinDll/Utils/Processes.hs +++ b/WinDll/Utils/Processes.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Windll @@ -55,7 +56,7 @@ proc' = name ++ (case platform session of Unix -> "" Windows -> ".exe") - inform _normal ("*** running " ++ name ++ "...") + inform _normal ("*** running " ++ name ++ " in (" ++ fullfile ++ ")...") inform _detail ("*** " ++ proc' ++ " " ++ unwords args') (pcode) <- liftIO $ do C.try $ Proc.createProcess @@ -169,13 +170,14 @@ ] ++ (if os /= Windows then ["-fPIC"] else []) ++ ["-shared" - ,"-o" ++ output + ,"-o" + ,output ,fullfile ++ name ++ ".hs" ,"dllmain.o" ] ++ (if os == Windows then ["exports.def"] else []) - ++ (if dynamic then ["-dynamic"] else []) -- ["-static"]) - ++ (if threaded session then ["-threaded"] else []) + ++ (if dynamic then ["-dynamic" ] else []) -- ["-static"]) + ++ (if threaded session then ["-threaded" ] else []) ++ ["-fno-warn-deprecated-flags" ,"-O2" ,"-package ghc" @@ -187,7 +189,8 @@ then ["-optl --enable-stdcall-fixup"] else [libdir "libHSrts.a"]) -- "-optl --disable-stdcall-fixup" - ++ ["-optl-Wl,-s" + ++ ["-optl" + ,"-Wl,-s" ,"-funfolding-use-threshold=16" ,"-optc-O3" ,"-optc-ffast-math" @@ -227,8 +230,11 @@ build = pipeline session fullfile = dirPath build liftIO $ copyFile (fullfile++output) (odir++output) +#if __GLASGOW_HASKELL__ >= 702 + liftIO $ copyFile (fullfile++name++".dll.a") (odir++extra) +#else liftIO $ copyFile (fullfile++"HSdll.dll.a") (odir++extra) - +#endif when (cpp session) $ do liftIO $ copyFile (fullfile++header) (odir++header) liftIO $ copyFile (fullfile++ffi) (odir++ffi)