Hs2lib 0.5.5 → 0.5.6
raw patch · 23 files changed
+291/−91 lines, 23 filesdep −haskell98
Dependencies removed: haskell98
Files
- Hs2lib.cabal +8/−7
- LIMITS.txt +15/−5
- Tests/FindFiles.hs +1/−1
- Tests/TestRunner.hs +3/−3
- WinDll/Builder.hs +8/−5
- WinDll/CmdArgs/Hs2lib.hs +3/−3
- WinDll/CodeGen/C.hs +12/−0
- WinDll/CodeGen/Lookup.hs +2/−2
- WinDll/Debug/Stack.xhs +1/−0
- WinDll/Identifier.hs +59/−36
- WinDll/Lib/Native.hs +32/−1
- WinDll/Lib/NativeMapping_Base.cpphs +49/−0
- WinDll/Session/Hs2lib.hs +6/−0
- WinDll/Structs/MShow/C.hs +14/−3
- WinDll/Structs/MShow/HaskellSrcExts.hs +1/−0
- WinDll/Structs/MShow/MShow.hs +1/−0
- WinDll/Utils/DepScanner.hs +13/−2
- WinDll/Utils/HaddockRead.hs +10/−4
- WinDll/Utils/KnownTypes.hs +5/−0
- WinDll/Utils/ListTypes.hs +7/−0
- WinDll/Utils/Processes.hs +39/−18
- WinDll/Utils/Types.hs +1/−0
- WinDll/Version/Hs2lib.hs +1/−1
Hs2lib.cabal view
@@ -1,5 +1,5 @@ Name: Hs2lib -Version: 0.5.5 +Version: 0.5.6 Cabal-Version: >= 1.10 Build-Type: Custom License: BSD3 @@ -46,9 +46,10 @@ Includes/WinDllSupport.h -Tested-With: GHC >= 6.12 +Tested-With: GHC >= 6.12 && < 7.3 Build-Depends: base >= 4, syb >= 0.1.0.2 + Extra-Source-Files: WinDll/*.hs, WinDll/CodeGen/*.hs, WinDll/CodeGen/CSharp/*.hs, @@ -174,7 +175,7 @@ Default-Language: Haskell98 Executable Hs2lib-testgen - Main-is: Tests\Exec\Hs2lib-testgen.hs + Main-is: Tests/Exec/Hs2lib-testgen.hs Build-Depends: QuickCheck >= 2.1.0.1, directory >= 1.0.0.3, @@ -207,18 +208,18 @@ Test-Suite test-regression type: exitcode-stdio-1.0 - main-is: Tests\Test-Regression.hs + main-is: Tests/Test-Regression.hs Default-Language: Haskell98 build-depends: base >= 4 && < 5, filepath >= 1.1.0.2, process >= 1.0.1.1, - haskell98 >= 1.1.0.1 + directory >= 1.0.0.3 Test-Suite test-regression-debug type: exitcode-stdio-1.0 - main-is: Tests\Test-Regression-Debug.hs + main-is: Tests/Test-Regression-Debug.hs Default-Language: Haskell98 build-depends: base >= 4 && < 5, filepath >= 1.1.0.2, process >= 1.0.1.1, - haskell98 >= 1.1.0.1+ directory >= 1.0.0.3
LIMITS.txt view
@@ -1,3 +1,14 @@+Version 0.5.6 + - Improved Linux compatibilies + - Added 64bit support + - Fixed an issue with typesynonyms 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 + - Added various warnings with suggestion + - Sandboxed the call to haddock, since this seems to fail quite easily. Produces + a warning and turns off haddock in case it fails + Version 0.5.5 - (Started) implementing a better test mechanism @@ -20,11 +31,10 @@ Version 0.5.0 - Added support for memory leak tracing with the --debug flag % Added support for qualified importing. It is now possible to export - values and types with the same name. - % - Added the ability to export polymorphic types. - % - Added support for infix constructors - + Does not support the ability to silence the generation of a free function - for a particular StablePtr + 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 Version 0.4.8 - Major restructuring of code to allow users to extend/override
Tests/FindFiles.hs view
@@ -2,7 +2,7 @@ import Control.Monad import Data.List-import Directory+import System.Directory import System.FilePath -- concatMapM, partitionM: pull out into monad utility lib? Does some version
Tests/TestRunner.hs view
@@ -17,11 +17,11 @@ -- | Run and test all the files in Tests\src runLocalTest :: IO () -runLocalTest = runTests "Tests\\src\\" False+runLocalTest = runTests "Tests/Src/" False -- | Run and test all the files in Tests\src with debugging enabled runLocalDebugTest :: IO () -runLocalDebugTest = runTests "Tests\\src\\" True+runLocalDebugTest = runTests "Tests/Src/" True -- | Automatically runs tests in the package. --@@ -50,7 +50,7 @@ runTest test db = do putStrLn ( "[Running test: " ++ test ++ "]" ) -- exit <- system ("hs2lib " ++ test) -- exit <- system ("hs2lib -v2 " ++ test ++ " > " ++ test ++ ".log")- let cmd = "hs2lib -v2 " ++ (if db then "--debug " else "") ++ test+ let cmd = "Hs2lib -v2 " ++ (if db then "--debug " else "") ++ test exit <- system cmd case exit of ExitSuccess -> return ()
WinDll/Builder.hs view
@@ -19,9 +19,9 @@ import WinDll.CmdArgs.Hs2lib import WinDll.Version.Hs2lib +import Control.Exception import Control.Monad -import System.IO.Error import System.Random import System.FilePath import System.Directory@@ -39,7 +39,7 @@ inform _normal ("*** Writing " ++ fullfile ++ "...") result <- liftIO $ try $ writeFile fullfile value case result of- Left err -> die ("Error when creating component '" ++ file ++ "': \n\t" ++ show err)+ Left err -> die ("Error when creating component '" ++ file ++ "': \n\t" ++ (show :: SomeException -> String) err) Right _ -> return () put $ session { pipeline = build { files = file:(files build) } } @@ -53,14 +53,17 @@ initialize = do session <- get nums <- liftIO $ randomRIO (0::Int,1000000)- let dir = (tempDIR session) ++ namespace session ++ show nums ++ [pathSeparator]+ let dir = (tempDIR session </> namespace session) ++ show nums ++ [pathSeparator] inform _normal ("*** Creating directory " ++ dir ++ "...") liftIO $ createDirectoryIfMissing True dir let build = pipeline session output = if null (outputFile session) then case platform session of- Unix -> namespace session ++ ".a"- Windows -> namespace session ++ ".dll"+ Unix -> case link_dynamic session of + -- False -> namespace session ++ ".a"+ _ -> namespace session ++ ".so"+ Windows -> case link_dynamic session of + _ -> namespace session ++ ".dll" else outputFile session odir <- case outputDIR session == "." of True -> liftIO getCurrentDirectory
WinDll/CmdArgs/Hs2lib.hs view
@@ -77,8 +77,8 @@ (o,n,[]) -> process (foldl (flip id) cfg o) n opt (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header opt)) where header = "Usage: " ++ name ++ " <input file> [OPTION...]"- name = if mode == Windows then exename ++ ".exe" else exename- opt = optDescr --if mode == Windows then optDescrClient else optDescrServer+ name = if mode == Windows then exename ++ ".exe" else exename+ opt = optDescr --if mode == Windows then optDescrClient else optDescrServer process a r opt = case Help `elem` opts of True -> ioError (userError $ usageInfo header opt)@@ -131,7 +131,7 @@ ++ boolFlag "M" "lib" (\cfg new -> cfg { mvcpp = new }) "create a .LIB file for use with the Microsoft Visual C++ compiler. NOTE: This requires the %VSBIN% (case sensitive) environment variable to be set." ++ boolFlag "d" "incl-def" (\cfg new -> cfg { incDef = new }) "Copy the generated .DEF file also to the specified output folder." ++ boolFlag "" "link-dyn" (\cfg new -> cfg { link_dynamic = new }) ("If you have the dynamic version of all your libs installed you can use this flag. (this includes having installed " ++ exename ++ " using -dynamic)")- ++ boolFlag "" "debug" (\cfg new -> cfg { debugging = new }) ("Enable debugging support which enabled memory profiling.")+ ++ boolFlag "" "debug" (\cfg new -> cfg { debugging = new }) ("Enable debugging support which enabled memory profiling.") ++ boolFlag "" "preserve-comments" (\cfg new -> cfg { pres_comment = new }) "Enabling this allows you to preserve the haddock description comments of your functions in the generated C _FFI file (Default True)" ++ boolFlag "" "preserve-foreigns" (\cfg new -> cfg { include_foreigns = new }) ("Enabling this will preserve and re-export any foreign declarations you already have declared in modules. NOTE: The Naming Convention must be the same as the generated functions. " ++ exename ++ " finds. (Default True)") ++ boolFlag "" "no-dllmain" (\cfg new -> cfg { dllmanual = new }) "Enabling this will allow you to manual initialise the RTS. Dllmain will no longer make the call to HsInit(). -L and --libmain will be ignored. (Default True)"
WinDll/CodeGen/C.hs view
@@ -144,9 +144,21 @@ -- declare the calling convention mkMacros conven = unlines ["#ifdef _MSC_VER" + ,"" + ,"#if _WIN64 || __amd64__" + ,"#define CALLTYPE(x) __declspec(dllimport) x" + ,"#else" ,"#define CALLTYPE(x) __declspec(dllimport) x __" ++ conven + ,"#endif" + ,"" ,"#else" + ,"" + ,"#if _WIN64 || __amd64__" + ,"#define CALLTYPE(x) x" + ,"#else" ,"#define CALLTYPE(x) x __attribute__((__" ++ conven ++ "__))" + ,"#endif" + ,"" ,"#endif"] return $ unlines $ mkHeader : ("#include \"" ++ name ++ ".h\"")
WinDll/CodeGen/Lookup.hs view
@@ -68,7 +68,7 @@ -- | Lookup the C type's size in the lookup table \c_sizes\, this is needed when __stdcall is used. lookupSize :: [(String, Int)] -> String -> Int -lookupSize c_sizes x = maybe 4 id (lookup x c_sizes) +lookupSize c_sizes x = maybe defaultPointerSize id (lookup x c_sizes) -- | Generate the appropriate C types from the given Haskell type createCType :: Defs -> Type -> TypeNames @@ -143,4 +143,4 @@ mkRet x = if "CBF" `isPrefixOf` x then x ++ "" - else x ++ "*"+ else x ++ "*"
WinDll/Debug/Stack.xhs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- |
WinDll/Identifier.hs view
@@ -77,15 +77,24 @@ -- liftIO $ print spec_datatypes when (not $ null missing) $ - warn ("Could not resolve the following " ++ show (length missing) ++ " type(s) which are needed: \n" ++ concatMap (\a->"\t - "++a++"\n") missing) + warn ("Could not resolve the following " ++ show (length missing) ++ " type(s) which are needed: \n" ++ + concatMap (\a->"\t - "++a++"\n") missing ++ + "\nIf these types are not to be exported try using the INSTANCE Hs2lib pragma\n") when (null f) $ die "No functions have been marked to be exported. There's nothing to generate. Stopping..." defs <- makeSessionAnn let mexports = exports merged ++ generateFreeExports mstableptr mstableptr = (nubBy ((==) `on` stType) $ findStableRefs d ++ findStableRefs f ) - mcallbacks = nubBy ((==) `on` simplify . cbInputType) $ generateCallbacksFromExports defs mexports ++ concatMap (genCallbacksFromDatatype defs) d - mdep = ModInfo + + calls1 <- generateCallbacksFromExports defs mexports + calls2 <- mapM (genCallbacksFromDatatype defs) d + + let mcallbacks = nubBy ((==) `on` simplify . cbInputType) $ calls1 ++ concat calls2 + + forM_ mcallbacks giveIOWarning + + let mdep = ModInfo (map (resolveFunctionCallbacks mcallbacks) f) -- ++ generateFreeFuncs mstableptr) (resolveCallback False mcallbacks (shifted simple_datatypes t_mods ,shifted spec_datatypes $ map fst spec)) @@ -126,47 +135,58 @@ -- | Generates callbacks for an Export type. This hides the original type -- b ecause if we don't, it'll generate too many specifications. -generateCallbacksFromExports :: Ann -> [Export] -> [Callback] -generateCallbacksFromExports defs xs = concatMap gen (zip xs [1..(length xs)]) - where gen :: (Export,Int) -> [Callback] - gen (exp,seed) = let cb1 = generateCallbacks defs seed (exType exp) - cb2 = generateCallbacks defs seed (exOrgType exp) - res = zipWith (\x y->update (x{cbInputType = cbOrigType y})) cb1 cb2 - update = \x-> let ty = analyzeType True (cbNewType x) - my = analyzeType False (cbOrigType x) - in x{ cbNewType = ty - , cbAnn = (cbAnn x){annArrayIndices = findListIndices ty} , cbOrigType = my} - in if length cb1 /= length cb2 - then error $ "Length mismatched, cannot generate callback types for " ++ show exp - else res +generateCallbacksFromExports :: Ann -> [Export] -> Exec [Callback] +generateCallbacksFromExports defs xs = fmap concat $ mapM gen (zip xs [1..(length xs)]) + where gen :: (Export,Int) -> Exec [Callback] + gen (exp,seed) = do cb1 <- generateCallbacks defs seed (exType exp) + cb2 <- generateCallbacks defs seed (exOrgType exp) + let res = zipWith (\x y->update (x{cbInputType = cbOrigType y})) cb1 cb2 + update = \x-> let ty = analyzeType True (cbNewType x) + my = analyzeType False (cbOrigType x) + in x{ cbNewType = ty + , cbAnn = (cbAnn x){annArrayIndices = findListIndices ty} , cbOrigType = my} + if length cb1 /= length cb2 + then die $ "Length mismatched, cannot generate callback types for " ++ show exp + else return res -- | Creates the list of callbacks found in function signatures. -- This relies on there not being unneeded parenthesis in types. e.g. -- a -> b -> (d -> d) will incorrectly generate a callback, which is never used -generateCallbacks :: Data a => Ann -> Int -> a -> [Callback] +generateCallbacks :: Data a => Ann -> Int -> a -> Exec [Callback] generateCallbacks cfg seed exports - = let types = listify isParen exports - ids = [seed..(seed + length types)] - in do (num, ty) <- zip ids types - let name = "CBF" ++ show num - newty = translatePartial (annWorkingSet cfg) ty - return $ Callback name ty newty (Exts.TyCon (Exts.Special Exts.UnitCon)) (cfg{ annArrayIndices = [], annArrayIsList = False }) - where isParen (Exts.TyParen a) = hasTyApp a - isParen _ = False - - hasTyApp = everything (||) (False `mkQ` isFun) + = return gen + where gen = let types = listify isParen exports + ids = [seed..(seed + length types)] + in do (num, ty) <- zip ids types + let name = "CBF" ++ show num + newty = translatePartial (annWorkingSet cfg) ty + return $ Callback name ty newty (Exts.TyCon (Exts.Special Exts.UnitCon)) (cfg{ annArrayIndices = [], annArrayIsList = False }) + isParen (Exts.TyParen a) = hasTyApp a + isParen _ = False + + hasTyApp = everything (||) (False `mkQ` isFun) + + isFun (Exts.TyFun{}) = True + isFun _ = False - isFun (Exts.TyFun{}) = True - isFun _ = False +-- | Generate a warning about a higher order type that are not in IO +giveIOWarning :: Callback -> Exec () +giveIOWarning cb | isIO (cbOrigType cb) = return () +giveIOWarning cb = do warn $ "The higher-order type argument '" ++ mshowM 2 ty ++ "' is not in IO," ++ + "\n this will most likely result in a segfault since I cannot convert " ++ + "\n between the expected type '" ++ mshowM 2 (mkIO ty) ++ "' and the given " ++ + "\n non-IO type in the current version of the library. Please lift your argument" ++ + "\n into IO to avoid the use of unsafePerformIO" + where ty = cbOrigType cb -- | Creates a list of callbacks from datatypes. This differs from general function -- in that to have a higher ordered function there is no need to have a parenthesis () -- in the type. Any abritrary function as type of one of the fields of a constructor -- indicated a higher order function. -genCallbacksFromDatatype :: Ann -> DataType -> [Callback] +genCallbacksFromDatatype :: Ann -> DataType -> Exec [Callback] genCallbacksFromDatatype defs (NewType a b c d) = genCallbacksFromDatatype defs (DataType a b [c] d) -genCallbacksFromDatatype defs (DataType a _ c _) = concatMap findCallbacks c - where findCallbacks :: DataType -> [Callback] +genCallbacksFromDatatype defs (DataType a _ c _) = fmap concat $ mapM findCallbacks c + where findCallbacks :: DataType -> Exec [Callback] findCallbacks (Constr n ft tys) = let values = filter (gIsFun . antType) tys mkC rec | a==n = Callback ("CBF" ++ a ++ nm) ty (translatePartial (annWorkingSet defs) ty) _ty (ann `mappend` defs) -- ^ temporary black whole | otherwise = Callback ("CBF" ++ a ++ n ++ nm) ty (translatePartial (annWorkingSet defs) ty) _ty (ann `mappend` defs) @@ -174,7 +194,8 @@ ty = addParen (antType rec) nm = antName rec ann = antAnn rec - in map mkC values + result = map mkC values + in return result -- | Find all TyApp beginning with StablePtr and return the right sides. findStableRefs :: (Data r, Typeable r) => r -> [Stable] @@ -266,7 +287,9 @@ m' = (apply adl m) { types = t } changed = m/=m' apply = flip (foldr ($)) - in if changed then fixpoint m' else m' + in if changed + then fixpoint m' + else everywhere (mkT (simplify :: Type -> Type)) m' -- correct types ------------------------------------------------------------------------------ -- | This is a hack to get a working first version. It basically merges all @@ -349,8 +372,8 @@ -- | Trace the structures needed for exporting this function traceF :: Bool -> Function -> TypeNames -traceF full fn = scan $ collectTypes (fnType fn) -- collectTypesEx knownPointerTypes args - where scan = (filter (\a->isNotPrim full a && filterTypeVars a)) +traceF full fn = scan $ collectTypesEx knownIgnorableTypes (fnType fn) -- collectTypes (fnType fn) + where scan = filter (\a->isNotPrim full a && filterTypeVars a) -- | Checks if the given type is not a primitive type isNotPrim :: Bool -> TypeName -> Bool
WinDll/Lib/Native.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Windll @@ -31,6 +32,7 @@ ,("Word64" , "uint64_t" ) ,("Float" , "float" ) ,("Double" , "double" ) + ,("CDouble" , "double" ) ,("CWString" , "wchar_t*" ) ,("CInt" , "int" ) ,("Bool" , "int8_t" ) @@ -104,6 +106,7 @@ ,("Word64" , "UInt64" ) ,("Float" , "float" ) ,("Double" , "double" ) + ,("CDouble" , "double" ) ,("CWString" , str ) ,("CInt" , "int" ) ,("Bool" , "bool" ) @@ -119,6 +122,7 @@ ,("()" , "void" )] where str = if struct then "char*" else "StringBuilder" +#if i386_HOST_ARCH -- | List containing mapping to CSizes nativeC_sizes ::[(String , Int)] nativeC_sizes = [("*" , 4) @@ -137,4 +141,31 @@ ,("char" , 1) ,("long long int" , 8) ,("void" , 0) - ]+ ] + +defaultPointerSize :: Int +defaultPointerSize = 4 +#else +-- | List containing mapping to CSizes +nativeC_sizes ::[(String , Int)] +nativeC_sizes = [("*" , 8) + ,("wchar_t" , 2) + ,("int" , 8) + ,("int8_t" , 1) + ,("int16_t" , 2) + ,("int32_t" , 4) + ,("int64_t" , 8) + ,("uint8_t" , 1) + ,("uint16_t" , 2) + ,("wchar_t" , 4) + ,("uint32_t" , 8) + ,("float" , 4) + ,("double" , 8) + ,("char" , 1) + ,("long long int" , 8) + ,("void" , 0) + ] + +defaultPointerSize :: Int +defaultPointerSize = 8 +#endif
WinDll/Lib/NativeMapping_Base.cpphs view
@@ -7,6 +7,8 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | @@ -238,6 +240,53 @@ -- 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)) + -- | I decided to use a CAString because on windows this gives me a constant 16 value instance FFIType String CWString where
WinDll/Session/Hs2lib.hs view
@@ -239,6 +239,12 @@ } } +-- | Escape paths with whitespaces+escapePath :: String -> String+escapePath path = if ' ' `elem` path+ then '"' : path ++ "\""+ else path+ -- | Guess the fullname of a target file guessPath :: FilePath -> IO FilePath guessPath mangled =
WinDll/Structs/MShow/C.hs view
@@ -72,7 +72,7 @@ ,map mshow d])) -- declare callback function pointers where callback_decls callbacks callconv- = let ccl = "__" ++ map toLower (genCcall callconv)+ = let ccl = map toLower (genCcall callconv) decls = unlines $ concatMap (\(Callback n t ty _oty ann) -> -- let x = createCType $ strip ty let x = createCType (annWorkingSetC ann) $ strip (translatePrimitive (annWorkingSet ann) t)@@ -85,10 +85,21 @@ False -> [" void "] args = intercalate ", " rest in ["// type " ++ n ++ " = " ++ mshowM 2 (strip t)- ,"typedef " ++ ccl ++ " " ++ restype ++ " (*" ++ n ++ "_t)(" ++ args ++ ");"]) callbacks + ,"CBF(" ++ restype ++ " (*" ++ n ++ "_t)(" ++ args ++ "));"]) callbacks + header = ["#if _WIN64 || __amd64__"+ ,"#define CBF(x) typedef x"+ ,"#else"+ ,""+ ,"#if __GNUC__ >= 4"+ ,"#define CBF(x) typedef x __attribute__((__" ++ ccl ++ "__))"+ ,"#else"+ ,"#define CBF(x) typedef __" ++ ccl ++ " x"+ ,"#endif"+ ,""+ ,"#endif"] in if null callbacks then [] - else ["", "// Callback functions typedefs", decls]+ else header ++ ["", "// Callback functions typedefs", decls] -- | Inline a DataField definition by removing one layer of wrapping from it. inline' :: DataField -> [DataField] inline' (Field _ _ _ _ x) = x
WinDll/Structs/MShow/HaskellSrcExts.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Windll
WinDll/Structs/MShow/MShow.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Windll
WinDll/Utils/DepScanner.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Windll@@ -23,6 +24,7 @@ import DynFlags import System.Environment import System.Directory+import System.FilePath ( replaceExtension ) -- | This module is self contained, So it can be used on it's own. main :: IO ()@@ -36,8 +38,9 @@ traceDeps :: Exec () traceDeps = do session <- get- let file = mainFile session- path = absPath session+ let file = mainFile session+ path = absPath session+ file' = replaceExtension path ".o" inform _normal $ "Tracing dependencies of file '" ++ file ++ "'" exists <- liftIO $ doesFileExist path when (not exists) $ do@@ -47,6 +50,10 @@ deps <- liftIO (getDeps file) let payload = (workingset session) { dependencies = deps } put $ session { workingset = payload }+ after <- liftIO $ doesFileExist file'+ when exists $ do+ liftIO $ removeFile file'+ inform _detail "Dependencies traced." inform _detail ("Dependencies are: " ++ unwords deps) @@ -57,7 +64,11 @@ -- | Get the module dependency graph of the given file getGraph :: String -> IO ModuleGraph getGraph file = +#if __GLASGOW_HASKELL__ >= 702+ defaultErrorHandler defaultLogAction $ do+#else defaultErrorHandler defaultDynFlags $ do+#endif runGhc (Just libdir) $ do dflags <- getSessionDynFlags setSessionDynFlags $ dflags { ghcMode = MkDepend , ghcLink = NoLink }
WinDll/Utils/HaddockRead.hs view
@@ -46,9 +46,15 @@ build = pipeline session case comment of False -> return M.empty- True -> do createProcess Nothing "haddock" createHoogle- specs <- liftIO $ fmap lines $ readFile ((addTrailingPathSeparator (dirPath build)) ++ "main.txt")- return $ parseHaddock specs M.empty+ True -> do success <- sandbox $ createProcess' Nothing False "haddock" createHoogle+ if success+ then do specs <- liftIO $ fmap lines $ readFile ((addTrailingPathSeparator (dirPath build)) ++ "main.txt")+ return $ parseHaddock specs M.empty+ else do warn $ "Haddock seems to have failed and has been disabled for the rest of the compilation." +++ "\n To not see this message again compile with --nopreserve-comments or fix your haddock"+ put $ session { pres_comment = False }+ return M.empty+ -- | Parse the haddock generated file and produce the map required parseHaddock :: [String] -> IndexedInterface -> IndexedInterface@@ -91,5 +97,5 @@ let paths = (absPath session : mpaths) return ("main.txt" , -- ["--optghc=\"-i" ++ if ' ' `elem` dir then show dir else dir ++ "\"" - ("--hoogle" : map (dir++) paths)+ ("--hoogle" : map (escapePath . makeValid . (dir++)) paths) )
WinDll/Utils/KnownTypes.hs view
@@ -29,6 +29,11 @@ -- because they matter not. knownPointerTypes :: TypeNames knownPointerTypes = ["StablePtr", "Ptr"]++-- | Types that the dependency tracer should ignore. And in the case that they are an applied type+-- everything on the right hand side should be ignored.+knownIgnorableTypes :: TypeNames+knownIgnorableTypes = ["StablePtr"] -- | The first lookup venue to GHC is looking up based on the type classes that we've already covered by the FFI class. -- So if the type is an instance of the following classes it's safe to ignore them.
WinDll/Utils/ListTypes.hs view
@@ -198,6 +198,13 @@ else if arr == 1 -- if there are no arguments, just directly apply mk then mk ty else processTypeNode arr mk ty + +-- | Updates the type of the higher-order function to be in IO +hofIO :: Exts.Type -> Exts.Type +hofIO = everywhere (mkT hof) + where hof :: Exts.Type -> Exts.Type + hof (Exts.TyParen ty) = Exts.TyParen (mkIO ty) + hof ty = ty -- | Checks to see if the function being returned is in IO isIO :: Exts.Type -> Bool
WinDll/Utils/Processes.hs view
@@ -20,13 +20,16 @@ import WinDll.Utils.Feedback import WinDll.EntryPoint +import qualified Control.Exception as C import Control.Monad+import Control.Monad.Error +import Data.Either+ import System.Random import System.FilePath import System.Directory import System.IO-import System.IO.Error import System.Environment import System.Process hiding (createProcess) import qualified System.Process as Proc@@ -38,9 +41,12 @@ type Process = FilePath -> Exec (String,[String]) -> Component --- | Create and run processes createProcess :: Maybe FilePath -> Process-createProcess wd name robot =+createProcess wd = createProcess' wd True++-- | Create and run processes+createProcess' :: Maybe FilePath -> Bool -> Process+createProcess' wd quit name robot = do (outfile,args) <- robot session <- get let build = pipeline session@@ -52,14 +58,16 @@ inform _normal ("*** running " ++ name ++ "...") inform _detail ("*** " ++ proc' ++ " " ++ unwords args') (pcode) <- - liftIO $ do try $ Proc.createProcess + liftIO $ do C.try $ Proc.createProcess (proc proc' args'){ cwd = wd `mplus` Just (fullfile) , std_out = CreatePipe , std_err = CreatePipe } (code,_out) <- case pcode of- Left err -> die ("Error running process '" ++ name ++ "' \n\t" ++ show err)+ Left err -> if quit+ then die ("Error running process '" ++ name ++ "' \n\t" ++ (show :: C.SomeException -> String) err)+ else error ("Error running process '" ++ name ++ "'") Right code -> readWhileWaitForProcess code case code of ExitSuccess -> do inform _detail _out@@ -68,8 +76,17 @@ put $ session { pipeline = build { files = outfile :(files build) } } (ExitFailure _) -> do inform _detail _out inform _normal ("*** process failed.") - die ("remote fault. failed to create " ++ outfile)+ (if quit then die else error) ("external fault. failed to create " ++ outfile) +-- | Sandbox a process, if it fails return false, if it was successful return true.+-- This can be used to isolate calls to createProcess that should not abort the +-- entire compilation+sandbox :: Component -> Exec Bool+sandbox action = + do session <- get + result <- liftIO $ C.try (runErrorT (evalStateT action session))+ return $ either (const False :: C.SomeException -> Bool) (const True) result+ -- | A helper function to loop and print only the information i want out. readWhileWaitForProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Exec (ExitCode,String) readWhileWaitForProcess full@(_, Just hout, Just herr, proccode) @@ -77,7 +94,7 @@ case ret of Just c -> liftIO ( hGetContents hout >>= (\v->hClose hout>>return v) ) >>= (\val -> return (c, val))- Nothing -> do p <- liftIO $ try (hLookAhead herr)+ Nothing -> do p <- liftIO $ C.try (hLookAhead herr) :: Exec (Either C.SomeException Char) case p of Right '[' -> (liftIO $ putStrLn =<< hGetLine herr) >> readWhileWaitForProcess full@@ -146,32 +163,36 @@ os = platform session dir = baseDir session extras = optGHC session+ dynamic = link_dynamic session return (output,["-fglasgow-exts" ,"--make" ] - ++ (if os == Windows then [] else ["-fPIC"]) ++- ["-shared"+ ++ (if os /= Windows then ["-fPIC"] else [])+ ++ ["-shared" ,"-o" ++ output ,fullfile ++ name ++ ".hs" ,"dllmain.o" ]- ++ (if os == Windows then ["exports.def"] else []) - ++ (if link_dynamic session then ["-dynamic"] else [])- ++ (if threaded session then ["-threaded"] else []) + ++ (if os == Windows then ["exports.def"] else []) + ++ (if dynamic then ["-dynamic"] else []) -- ["-static"])+ ++ (if threaded session then ["-threaded"] else []) ++ ["-fno-warn-deprecated-flags" ,"-O2" ,"-package ghc" ,"-package Hs2lib"- ,"-i" ++ if ' ' `elem` dir then show dir else dir- --,"-outputdir " ++ if ' ' `elem` odir then show odir else odir- ,"-optl --enable-stdcall-fixup"- --,"-optl --disable-stdcall-fixup"- ,"-optl-Wl,-s"+ ,"-i" ++ if ' ' `elem` dir then escapePath dir else dir+ --,"-outputdir " ++ if ' ' `elem` odir then escapePath odir else odir+ ]+ ++ (if os == Windows + then ["-optl --enable-stdcall-fixup"] + else [libdir </> "libHSrts.a"])+ -- "-optl --disable-stdcall-fixup"+ ++ ["-optl-Wl,-s" ,"-funfolding-use-threshold=16" ,"-optc-O3" ,"-optc-ffast-math" ]- ++ if null extras then [] else [extras] +++ ++ (if null extras then [] else [extras]) ++ [ -- ,"-debug" -- ,"-fno-full-laziness" -- due to calls to unsafePerformIO
WinDll/Utils/Types.hs view
@@ -27,6 +27,7 @@ instance Simplify Type where simplify = simplifyParenthesis + -- | This function strips all unneeded parenthesis and keeps -- only the bare minimum or parenthesis in types. We do this -- to normalize the types and makes them easier to compare.
WinDll/Version/Hs2lib.hs view
@@ -19,7 +19,7 @@ -- | Version Number verNum :: [Int] -verNum = [0,5,5] +verNum = [0,5,6] -- | Version string verStr :: String