Hs2lib 0.6.1 → 0.6.3
raw patch · 17 files changed
+75/−101 lines, 17 filesdep ~ghcdep ~haskell-src-exts
Dependency ranges changed: ghc, haskell-src-exts
Files
- Hs2lib.cabal +16/−12
- LIMITS.txt +5/−0
- Tests/FindFiles.hs +1/−1
- WinDll/CodeGen/CSharp/CSharp.hs +1/−1
- WinDll/CodeGen/Haskell.hs +16/−9
- WinDll/CodeGen/Lookup.hs +10/−2
- WinDll/Debug/Output.hs +1/−1
- WinDll/Lib/Instances.hs +0/−1
- WinDll/Lib/NativeMapping_Base.cpphs +2/−50
- WinDll/Lib/Tuples_Base.cpphs +0/−1
- WinDll/Parsers/Hs2lib.hs +1/−1
- WinDll/Structs/Folds/Haskell.hs +6/−6
- WinDll/Structs/Haskell.hs +3/−2
- WinDll/Structs/MShow/Alignment.hs +1/−1
- WinDll/Structs/MShow/CSharp.hs +5/−5
- WinDll/Structs/MShow/Haskell.hs +6/−7
- WinDll/Version/Hs2lib.hs +1/−1
Hs2lib.cabal view
@@ -1,5 +1,5 @@ Name: Hs2lib -Version: 0.6.1 +Version: 0.6.3 Cabal-Version: >= 1.10 Build-Type: Custom License: BSD3 @@ -16,7 +16,9 @@ . It will always generated the required C types for use when calling the dll, but it will also generate the C# unsafe code if requested. . - Read http://blog.zhox.com/hs2lib.pdf (not published yet) + Read http://www.scribd.com/doc/63918055/Hs2lib-Tutorial#scribd + . + A replacement for this library is in development and will eventually replace this . Current Restrictions: . @@ -28,6 +30,8 @@ . - Does not support automatic instance generation for infix constructors yet . + - List of Lists are not supported (concat them first). + . NOTE: Package is now working again, but I have fixed the version of haskell-src-exts to prevent it from breaking again. . Data-Files: Templates/main.template-unix.c, @@ -50,7 +54,7 @@ Includes/WinDllSupport.h -Tested-With: GHC >= 6.12 && < 7.7 +Tested-With: GHC >= 7.8.3 Build-Depends: base >= 4, syb >= 0.1.0.2 @@ -96,8 +100,8 @@ WinDll.Lib.Tuples_Debug, WinDll.Structs.Types - Build-Depends: haskell-src-exts == 1.13.5, - ghc >= 6.12 && < 7.0 || >= 7.0.2, + Build-Depends: haskell-src-exts >= 1.13.5 && <= 1.15.0.1, + ghc >= 7.8.3, base >= 4 && < 5, filepath >= 1.1.0.2, old-locale >= 1.0.0.2, @@ -125,11 +129,11 @@ filepath >= 1.1.0.2, random >= 1.0.0.1, process >= 1.0.1.1, - ghc >= 6.12 && < 7.0 || >= 7.0.2, + ghc >= 7.8.3, mtl >= 1.1.0.2, containers >= 0.2.0.0, array >= 0.2.0.0, - haskell-src-exts == 1.13.5, + haskell-src-exts >= 1.13.5 && <= 1.15.0.1, haddock >= 2.7.2, base >= 4 && < 5, syb >= 0.1.0.2, @@ -155,11 +159,11 @@ filepath >= 1.1.0.2, random >= 1.0.0.1, process >= 1.0.1.1, - ghc >= 6.12 && < 7.0 || >= 7.0.2, + ghc >= 7.8.3, mtl >= 1.1.0.2, containers >= 0.2.0.0, array >= 0.2.0.0, - haskell-src-exts == 1.13.5, + haskell-src-exts >= 1.13.5 && <= 1.15.0.1, haddock >= 2.7.2, base >= 4 && < 5, syb >= 0.1.0.2, @@ -187,11 +191,11 @@ filepath >= 1.1.0.2, random >= 1.0.0.1, process >= 1.0.1.1, - ghc >= 6.12 && < 7.0 || >= 7.0.2, + ghc >= 7.8.3, mtl >= 1.1.0.2, containers >= 0.2.0.0, array >= 0.2.0.0, - haskell-src-exts == 1.13.5, + haskell-src-exts >= 1.13.5 && <= 1.15.0.1, haddock >= 2.7.2, base >= 4 && < 5, syb >= 0.1.0.2, @@ -226,4 +230,4 @@ build-depends: base >= 4 && < 5, filepath >= 1.1.0.2, process >= 1.0.1.1, - directory >= 1.0.0.3+ directory >= 1.0.0.3
LIMITS.txt view
@@ -1,3 +1,8 @@+Version 0.6.1 + - The List type has been changed in Haskell-Src-Exts this has caused a lot of the functionality to break + - Currently I support Lists again, but not List of Lists e.g. [[Int]]. I will not fix this, concat the list to use it. + - HsExport will eventually be released and will replace this package. + Version 0.5.7 - Added support for the newer GHC's 7.6.x - Improved Linux support
Tests/FindFiles.hs view
@@ -2,7 +2,7 @@ import Control.Monad import Data.List-import System.Directory+import System.Directory hiding (findFiles) import System.FilePath -- concatMapM, partitionM: pull out into monad utility lib? Does some version
WinDll/CodeGen/CSharp/CSharp.hs view
@@ -142,7 +142,7 @@ ,LibInclude "System.Runtime.InteropServices" ,LibInclude "WinDll" ,LocalInclude "Utils"- ,LocalInclude "Generated.Types"+ ,LocalInclude $ "Generated.Types." ++ classname ] , _structs = map upgradeField (join structs) , _typeDecls = []
WinDll/CodeGen/Haskell.hs view
@@ -20,6 +20,7 @@ import WinDll.Structs.Haskell hiding (pragmas) import WinDll.Structs.MShow.MShow import WinDll.Structs.MShow.Haskell+import WinDll.Structs.MShow.Alignment import WinDll.Structs.Folds.Haskell import WinDll.Utils.Pragma @@ -124,8 +125,8 @@ (map (mkExport ann (call session)) _exports ++ natives) (concatMap (mkImport ann (call session)) callbacks) (map (mkFunction ann) (modFunctions modInfo))- ( map (generateStorageCode ann True) simple_datatypes- ++ map (generateStorageCode ann True) specials)+ ( map (generateStorageCode ann True (fullfile, name, bdir)) simple_datatypes+ ++ map (generateStorageCode ann True (fullfile, name, bdir)) specials) callbacks stables @@ -225,21 +226,27 @@ where enum (Constr name _ _) = filter isAlphaNum name -- filter isAlpha (map toLower name) -- | Create the Storage instances needed by Haskell's HSC PreProcessor-generateStorageCode :: Ann -> Bool -> DataType -> HaskellStorable-generateStorageCode ann esc d = generateTopLevelStruct d+generateStorageCode :: Ann -> Bool -> (String, String, String) -> DataType -> HaskellStorable+generateStorageCode ann esc (path, nspace, opath) d = generateTopLevelStruct d where generateTopLevelStruct :: DataType -> HaskellStorable generateTopLevelStruct (NewType name e t tag) = generateTopLevelStruct (DataType name e [t] tag) generateTopLevelStruct (DataType name e t tag) = let peeks = HSPeek (mkPeekHead name (isNewType d) e ++ rollFn mkPeek name (isNewType d) t)- po = mkFn (mkPoke e) name (isNewType d) t+ po = mkFn (mkPoke e size) name (isNewType d) t+ + mal_size [_] = resolveAlignment path nspace opath name []+ mal_size xs = resolveAlignment path nspace opath name xs+ sizes :: [(Name,Int)] sizes = map getSize t where getSize :: DataType -> (Name,Int) getSize (Constr name ft ntypes) = (name, length ntypes)+ + size = mal_size sizes - in HSStorable name sizes "ptr" e esc po [peeks] ann+ in HSStorable name sizes size "ptr" e esc po [peeks] ann dbg = annDebug ann modnm = annModule ann@@ -254,11 +261,11 @@ rollFn :: (Int -> FuncP) -> Name -> Bool -> [DataType] -> [StorablePeek] rollFn fn name newtpe constrs =join $ zipWith ($) (map (\c a -> fn a name newtpe c) constrs) [0..(length constrs - 1)] - mkPoke :: [String] -> Func- mkPoke e dna newtpe (Constr name ft ntypes) = + mkPoke :: [String] -> Int -> Func+ mkPoke e size dna newtpe (Constr name ft ntypes) = let col = case newtpe of False -> [PokeTag dna "tag" _ptr (PokeValue enum)- ,NewPtr dbg _newptr dnamod+ ,NewPtr dbg _newptr dnamod size ] ++ inner ++ [PokeTag dna "elt" _ptr (PokeValue _newptr)] True -> concat $ zipWith (\x (c,b)->let base = PokeTag dna (antName x) _ptr (PokeVar dbg esc b Nothing c ann)
WinDll/CodeGen/Lookup.hs view
@@ -76,7 +76,11 @@ = foldType( const . const id , (++) , (\_ b -> return ("Tuple"++show (length b)++"_t*")) - , (\a -> map (\t -> if "CBF" `isPrefixOf` t then t ++ "_t" else t ++ "*") a) + , (\a -> map (\t -> if "CBF" `isPrefixOf` t + then t ++ "_t" + else if "*" `isSuffixOf` t + then t -- Don't make lists of pointer types **, however this hack means list of lists are not supported.To support this pass a flag down and check if the previous entry was a list + else t ++ "*") a) , (\a b -> process a b) , (\a ->maybe [mkRet a] (:[]) (lookup a clist)) . mshow , (\a ->maybe [mkRet a] (:[]) (lookup a clist)) . mshow @@ -121,7 +125,11 @@ = foldType( const . const id , (++) , (\_ b -> return ("Tuples.Tuple"++show (length b)++"*")) - , (\a -> map ((\t -> if "CBF" `isPrefixOf` t then t ++ "" else t ++ "*") . swapList) a) + , (\a -> map ((\t -> if "CBF" `isPrefixOf` t + then t ++ "_t" + else if "*" `isSuffixOf` t + then t -- Don't make lists of pointer types **, however this hack means list of lists are not supported. + else t ++ "*") . swapList) a) , (\a b -> process a b) -- We want to ignore IO, we assume all the functions preserve ref. transparency. in the case of FFI , (\a ->maybe [mkRet a] (:[]) (lookup a cslist')) . mshow , (\a ->maybe [mkRet a] (:[]) (lookup a cslist')) . mshow
WinDll/Debug/Output.hs view
@@ -89,7 +89,7 @@ displayResults mem = do echo $ "Found " ++ show (memRSize mem) ++ " outstanding allocation(s)." when (memUnAlloc mem > 0) $ echo $ "Unable to resolve " ++ show (memUnAlloc mem) ++ " allocation(s)." liftIO $ mapM_ print $ memOuts mem - when (memUnAlloc mem == 0) $ liftIO $ putStrLn "Congratulations, No memory leak(s) detected." + when (memUnAlloc mem == 0 && memRSize mem == 0) $ liftIO $ putStrLn "Congratulations, No memory leak(s) detected." -- | Discover file locations discoverFiles :: Exec ()
WinDll/Lib/Instances.hs view
@@ -31,7 +31,6 @@ import Foreign.Marshal.Utils import Control.Monad -import Control.Monad.Instances import Control.Arrow import Data.List
WinDll/Lib/NativeMapping_Base.cpphs view
@@ -56,7 +56,6 @@ import Control.Exception (bracket) import Control.Monad -import Control.Monad.Instances import Data.Char import Data.List @@ -239,54 +238,7 @@ -- be used by types which define toFFI/fromFFI instead of toNative/fromNative -- instance (FFIType a b, FFIType c d) => FFIType (a -> c) (b -> d) where -- toFFI _ST_ f x = toFFI _ST_ (f (fromFFI _ST_ x)) - -- fromFFI _ST_ f x = fromFFI _ST_ (f (toFFI _ST_ x)) - -newtype Pure a = Pure{ pure :: a } - deriving Functor - --- instance FFIType a b => FFIType (Pure a) (Pure b) where - -- toFFI _ST_ = Pure . toFFI _ST_ . pure - -- fromFFI _ST_ = Pure . fromFFI _ST_ . pure - -- toNative _ST_ = fmap Pure . toNative _ST_ . pure - -- fromNative _ST_ = fmap Pure . fromNative _ST_ . pure -instance FFIType (Pure Int) (Pure CInt) where - toFFI _ST_ = fmap (toFFI _ST_) - fromFFI _ST_ = fmap (fromFFI _ST_) - -instance FFIType (Pure Float) (Pure CFloat) where - toFFI _ST_ = fmap (toFFI _ST_) - fromFFI _ST_ = fmap (fromFFI _ST_) - -instance (Num a,Integral a) => FFIType (Pure Integer) (Pure a) where - toFFI _ST_ = fmap (toFFI _ST_) - fromFFI _ST_ = fmap (fromFFI _ST_) - -instance FFIType (Pure Char) (Pure CChar) where - toFFI _ST_ = fmap (toFFI _ST_) - fromFFI _ST_ = fmap (fromFFI _ST_) - -instance FFIType (Pure Rational) (Pure CDouble) where - toFFI _ST_ = fmap (toFFI _ST_) - fromFFI _ST_ = fmap (fromFFI _ST_) - -instance FFIType (Pure Char) (Pure CWchar) where - toFFI _ST_ = fmap (toFFI _ST_) - fromFFI _ST_ = fmap (fromFFI _ST_) - -instance FFIType a b => FFIType (Pure [a]) (Pure [b]) where - toFFI _ST_ = fmap (fmap (toFFI _ST_)) - fromFFI _ST_ = fmap (fmap (fromFFI _ST_)) - -instance ( FFIType (Pure a) (Pure b) - , FFIType (Pure c) (Pure d) - , FFIType c d - , FFIType a b) - => FFIType (Pure (a -> c)) (Pure (b -> d)) where - toFFI _ST_ f = Pure $ to (pure f) - where to f x = toFFI _ST_ (f (fromFFI _ST_ x)) - fromFFI _ST_ f = Pure $ from (pure f) - where from f x = fromFFI _ST_ (f (toFFI _ST_ x)) - + -- fromFFI _ST_ f x = fromFFI _ST_ (f (toFFI _ST_ x)) -- | I decided to use a CWString because on windows this gives me a constant 16 value instance FFIType String CWString where @@ -413,7 +365,7 @@ #else poke ptr value = do newptr <- newArray value #endif - copyArray (castPtr ptr) newptr (length value) + moveArray (castPtr ptr) newptr (length value) #ifdef DEBUG (FREE(__FILE__, __LINE__, "freeArray", F.free)) emptyStack undefined ptr #else
WinDll/Lib/Tuples_Base.cpphs view
@@ -42,7 +42,6 @@ import Foreign.Marshal.Utils import Control.Monad-import Control.Monad.Instances #ifdef DEBUG import WinDll.Debug.Stack
WinDll/Parsers/Hs2lib.hs view
@@ -141,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 = (map EnableExtension [TemplateHaskell, BangPatterns, NamedFieldPuns, ExplicitForAll] ++ glasgowExts), parseFilename = path, fixities = Just baseFixities }) path case result of (ParseOk a) -> return a (ParseFailed loc str) -> die (exename ++ " parse failure, reason: " ++ str ++ " at " ++ show loc)
WinDll/Structs/Folds/Haskell.hs view
@@ -21,7 +21,7 @@ -- * General type algebras -- | Type Algebra for the HaskellStorable ADT-type HaskellStorableAlgebra a = ((Name -> [(Name,Int)] -> PtrName -> [TypeName] -> Bool -> [a] -> [a] -> Ann -> a)+type HaskellStorableAlgebra a = ((Name -> [(Name,Int)] -> Int -> PtrName -> [TypeName] -> Bool -> [a] -> [a] -> Ann -> a) ,(Name -> ModuleName -> Int -> [StorablePoke] -> a) ,([StorablePeek] -> a) )@@ -35,7 +35,7 @@ -- | Type Algebra for the StorablePoke ADT type StorablePokeAlgebra a = ((TypeName -> Field -> PtrName -> a -> a)- ,(Bool -> Name -> TypeName -> a)+ ,(Bool -> Name -> TypeName -> Int -> a) ,(Name -> a) ,(Bool -> Bool -> Name -> Maybe Name -> Type -> Ann -> a) ,ModuleName -> a@@ -46,9 +46,9 @@ -- | General fold for the HaskellStorable ADT foldHaskellStorable :: HaskellStorableAlgebra a -> HaskellStorable -> a foldHaskellStorable (hsstorable,hspoke,hspeek) = fold- where fold (HSStorable a b c d e f g h) = hsstorable a b c d e (map fold f) (map fold g) h- fold (HSPoke a b c d) = hspoke a b c d- fold (HSPeek a) = hspeek a+ where fold (HSStorable a b c d e f g h i) = hsstorable a b c d e f (map fold g) (map fold h) i+ fold (HSPoke a b c d) = hspoke a b c d+ fold (HSPeek a) = hspeek a -- | General fold for the StorablePeek ADT foldStorablePeek :: StorablePeekAlgebra a -> StorablePeek -> a@@ -62,7 +62,7 @@ foldStorablePoke :: StorablePokeAlgebra a -> StorablePoke -> a foldStorablePoke (tag,new,val,var,ret) = fold where fold (PokeTag a b c d) = tag a b c (fold d)- fold (NewPtr a b c) = new a b c+ fold (NewPtr a b c d) = new a b c d fold (PokeValue a) = val a fold (PokeVar a b c d e f) = var a b c d e f fold (PokeReturn a) = ret a
WinDll/Structs/Haskell.hs view
@@ -70,7 +70,8 @@ -- | A datatype to hold all Storable instance definitions (Both normal and specializations) data HaskellStorable = HSStorable { hsname :: Name -- ^ @hsname@ Name of the storable instance- , hsizes :: [(Name,Int)] -- ^ @hssizes@ A mapping from Constructors to arity to generate correct sizes+ , hssizes :: [(Name,Int)] -- ^ @hssizes@ A mapping from Constructors to arity to generate correct sizes+ , hssize :: Int -- ^ @hssize@ The resolved size of constructors, largest size this structure can hold , hsptr :: PtrName -- ^ @hsptr@ The base pointer name to use in this instance , hsvars :: [TypeName] -- ^ @hsvars@ The full type arity of the datatype , hsspec :: Bool -- ^ @hsspec@ Whether the instance is a specialized instance or not. If it is FFIType should not be used and the types not escaped.@@ -96,7 +97,7 @@ -- | Structure to describe the Poke values in a Storable instance data StorablePoke = PokeTag TypeName Field PtrName StorablePoke- | NewPtr Bool Name TypeName+ | NewPtr Bool Name TypeName Int | PokeValue Name | PokeVar Bool Bool Name (Maybe Name) Type Ann | PokeReturn ModuleName
WinDll/Structs/MShow/Alignment.hs view
@@ -45,7 +45,7 @@ let full = _name : map fst list hsc = createHSC nspace full (a:x:xs) = executeHSC path ldir _name hsc- size = x + foldl' max 0 xs+ size = x `max` foldl' max 0 xs in case size `mod` a of 0 -> size _ -> size + (a - (size `mod` a))
WinDll/Structs/MShow/CSharp.hs view
@@ -25,13 +25,13 @@ import Data.List instance MShow CsInclude where- mshow = foldInclude ((\a->"using "++a++";")- ,(\a->"using WinDll."++a++";")+ mshow = foldInclude (\a->"using "++a++";"+ ,\a->"using WinDll."++a++";" ) . csUnpackInclude instance MShow CsDataEnum where- mshow = foldDataEnum ((\a b->let fix = foldr1 (\a b->a++", "++b) . map (("c"++a)++)- in "public enum List"++a++" {" ++ fix b ++ "};")) . csUnpackEnum+ mshow = foldDataEnum (\a b->let fix = foldr1 (\a b->a++", "++b) . map (("c"++a)++)+ in "public enum List"++a++" {" ++ fix b ++ "};") . csUnpackEnum instance MShow Attr where mshow = foldAttr (\p k v -> let pre = case p of@@ -114,7 +114,7 @@ csrts ++ [" }" ,"}"- ,nm ++ ".Types"+ ,nm ++ ".Types." ++ _class cs ,"{" ] ++ zipWith id (repeat (" /// "++)) (lines $ _header cs) ++ csenum ++ [""] ++
WinDll/Structs/MShow/Haskell.hs view
@@ -20,7 +20,6 @@ import WinDll.Structs.Structures hiding (Import,imports,Pragma) import WinDll.Structs.Folds.C import WinDll.Structs.C-import WinDll.Structs.MShow.Alignment import WinDll.Parsers.Hs2lib import WinDll.Utils.ListTypes @@ -232,7 +231,7 @@ mshow _ = error "HaskellStorable: mshow - please call mshowWithPath" mshowWithPath dbg path nspace opath = foldHaskellStorable (hsstorable,hspoke,hspeek) where - hsstorable _name _size _ptr _vars+ hsstorable _name _size _hsize _ptr _vars _spec _pok _pek _ann = unlines' $ ("instance " ++ inst_head ++ "Storable " ++ val_head ++ " where") : (map indent $ (val_size _size) : @@ -258,8 +257,8 @@ val_head = case (length _vars) > 0 of False -> _name True -> "(" ++ _name ++ " " ++ unwords _vars ++")"- val_size [_] = "sizeOf _ = " ++ show (resolveAlignment path nspace opath _name [])- val_size xs = "sizeOf _ = " ++ show (resolveAlignment path nspace opath _name xs)+ val_size [_] = "sizeOf _ = " ++ show _hsize+ val_size xs = "sizeOf _ = 8 " -- hardcoded to 8, e.g one pointer + one int32 (tag + elt) adj [] = [] adj (x:xs) = (indent $ "poke " ++ _ptr ++ " "++x):(map indent xs) mkHead x = "(" ++ foldr1 (\a b->a++", "++b) x ++ ")"@@ -308,9 +307,9 @@ in case lines (mshow _poke) of [_name, _rest] -> unlines' [ _rest, mk _name ] _rest -> mk $ unlines' _rest- new dbg _name _type = if dbg - then _name ++ " <- malloc (newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"()\")) :: IO (Ptr " ++ _type ++ ")"- else _name ++ " <- malloc :: IO (Ptr " ++ _type ++ ")"+ new dbg _name _type _size = if dbg + then _name ++ " <- mallocBytes " ++ show _size ++ " (newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"()\")) :: IO (Ptr " ++ _type ++ ")"+ else _name ++ " <- mallocBytes " ++ show _size ++ " :: IO (Ptr " ++ _type ++ ")" val _val = _val var dbg _b _name _ren _type _ann = let mk = if _b
WinDll/Version/Hs2lib.hs view
@@ -19,7 +19,7 @@ -- | Version Number verNum :: [Int] -verNum = [0,6,1] +verNum = [0,6,3] -- | Version string verStr :: String