Hs2lib 0.5.6 → 0.5.7
raw patch · 29 files changed
+1287/−54 lines, 29 filesdep ~filepathdep ~haskell-src-exts
Dependency ranges changed: filepath, haskell-src-exts
Files
- Announce.txt +63/−0
- FFI.hs +174/−0
- Hs2lib-debug.hs +1/−1
- Hs2lib.cabal +11/−9
- Hs2lib.hs +1/−1
- LIMITS.txt +9/−4
- TODO.txt +15/−0
- Templates/.svn/all-wcprops +5/−0
- Templates/.svn/dir-prop-base +14/−0
- Templates/.svn/entries +164/−0
- Templates/.svn/text-base/main.template-unix.c.svn-base +26/−0
- Templates/.svn/text-base/main.template-win.c.svn-base +23/−0
- Templates/.svn/text-base/nomain.template-unix.c.svn-base +21/−0
- Templates/.svn/text-base/nomain.template-win.c.svn-base +22/−0
- Templates/nomain.template-win.c +2/−2
- Tests/Exec/Analyze.hs +56/−1
- Tests/Exec/Example.hs +1/−1
- Tests/Exec/Hs2lib-testgen.hs +1/−1
- Tests/Exec/Structs.hs +10/−2
- WinDll/Debug/Output.hs +2/−2
- WinDll/Debug/Stack.xhs +1/−1
- WinDll/EntryPoint.hs +2/−4
- WinDll/Identifier.hs +44/−8
- WinDll/Parsers/Hs2lib.bak +586/−0
- WinDll/Parsers/Hs2lib.hs +13/−5
- WinDll/Session/Hs2lib.hs +4/−4
- WinDll/Structs/MShow/HaskellSrcExts.hs +1/−1
- WinDll/Utils/DepScanner.hs +3/−1
- WinDll/Utils/Processes.hs +12/−6
+ Announce.txt view
@@ -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.
+ FFI.hs view
@@ -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
Hs2lib-debug.hs view
@@ -2,7 +2,7 @@ -- | -- Module : Windll -- Copyright : (c) Tamar Christina 2009 - 2010 --- License : GPL +-- License : BSD3 -- -- Maintainer : tamar@zhox.com -- Stability : experimental
Hs2lib.cabal view
@@ -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 <tamar@zhox.com> -Maintainer: Tamar Christina <tamar@zhox.com> +Author: Tamar Christina <tamar (at) zhox.com> +Maintainer: Tamar Christina <tamar (at) zhox.com> 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,
Hs2lib.hs view
@@ -2,7 +2,7 @@ -- | -- Module : Windll -- Copyright : (c) Tamar Christina 2009 - 2010 --- License : GPL +-- License : BSD3 -- -- Maintainer : tamar@zhox.com -- Stability : experimental
LIMITS.txt view
@@ -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
+ TODO.txt view
@@ -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 []
+ Templates/.svn/all-wcprops view
@@ -0,0 +1,5 @@+K 25+svn:wc:ra_dav:version-url+V 46+/svn/WinDll/!svn/ver/37/trunk/WinDLL/Templates+END
+ Templates/.svn/dir-prop-base view
@@ -0,0 +1,14 @@+K 10+svn:ignore+V 52+*.hi+*.aux+*.blg+*.out+*.log+*.gz+*.idx+*.toc+*.bbl++END
+ Templates/.svn/entries view
@@ -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+
+ Templates/.svn/text-base/main.template-unix.c.svn-base 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/.svn/text-base/main.template-win.c.svn-base 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/.svn/text-base/nomain.template-unix.c.svn-base 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/.svn/text-base/nomain.template-win.c.svn-base 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(); +}
Templates/nomain.template-win.c view
@@ -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(); }
Tests/Exec/Analyze.hs view
@@ -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"
Tests/Exec/Example.hs view
@@ -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
Tests/Exec/Hs2lib-testgen.hs view
@@ -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
Tests/Exec/Structs.hs view
@@ -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
WinDll/Debug/Output.hs view
@@ -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 }
WinDll/Debug/Stack.xhs view
@@ -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 </> "..."
WinDll/EntryPoint.hs view
@@ -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
WinDll/Identifier.hs view
@@ -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
+ WinDll/Parsers/Hs2lib.bak view
@@ -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 <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+-- . {- @@ HS2CS <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`+-- . {- @@ 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)
WinDll/Parsers/Hs2lib.hs view
@@ -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"
WinDll/Session/Hs2lib.hs view
@@ -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
WinDll/Structs/MShow/HaskellSrcExts.hs view
@@ -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
WinDll/Utils/DepScanner.hs view
@@ -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
WinDll/Utils/Processes.hs view
@@ -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)