Hs2lib 0.5.2 → 0.5.5
raw patch · 26 files changed
+914/−326 lines, 26 filesdep ~filepathnew-component:exe:Hs2lib-testgen
Dependency ranges changed: filepath
Files
- Hs2lib.cabal +34/−1
- LIMITS.txt +12/−0
- Tests/Exec/Analyze.hs +27/−0
- Tests/Exec/CmdArgs.hs +162/−0
- Tests/Exec/Default.hs +44/−0
- Tests/Exec/Example.hs +29/−0
- Tests/Exec/Hs2lib-testgen.hs +65/−0
- Tests/Exec/Structs.hs +42/−0
- Tests/Exec/Version.hs +44/−0
- WinDll/CmdArgs/Hs2lib.hs +3/−1
- WinDll/CodeGen/C.hs +2/−1
- WinDll/CodeGen/CSharp/CSharp.hs +27/−26
- WinDll/CodeGen/Haskell.hs +12/−5
- WinDll/Identifier.hs +5/−20
- WinDll/Lib/Native.hs +16/−16
- WinDll/Lib/NativeMapping_Base.cpphs +14/−8
- WinDll/Parsers/Hs2lib.hs +14/−204
- WinDll/Session/Hs2lib.hs +2/−0
- WinDll/Structs/MShow/Haskell.hs +42/−33
- WinDll/Structs/MShow/HaskellSrcExts.hs +26/−4
- WinDll/Structs/Structures.hs +14/−3
- WinDll/Utils/KnownTypes.hs +36/−0
- WinDll/Utils/ListTypes.hs +231/−0
- WinDll/Utils/Pragma.hs +5/−3
- WinDll/Utils/Processes.hs +5/−0
- WinDll/Version/Hs2lib.hs +1/−1
Hs2lib.cabal view
@@ -1,5 +1,5 @@ Name: Hs2lib -Version: 0.5.2 +Version: 0.5.5 Cabal-Version: >= 1.10 Build-Type: Custom License: BSD3 @@ -66,6 +66,7 @@ WinDll/Structs/MShow/*.hs, WinDll/Utils/*.hs, Tests/*.hs, + Tests/Exec/*.hs, Tests/Src/*.hs, Tests/Src/*.txt, *.hs, @@ -163,6 +164,38 @@ ghc-options: -threaded -fspec-constr-count=16 -rtsopts cpp-options: -DDEBUG + + Other-Modules: Paths_Hs2lib, + WinDll.Lib.NativeMapping, + WinDll.Lib.NativeMapping_Debug, + WinDll.Debug.Records, + WinDll.Debug.Stack + + Default-Language: Haskell98 + +Executable Hs2lib-testgen + Main-is: Tests\Exec\Hs2lib-testgen.hs + + Build-Depends: QuickCheck >= 2.1.0.1, + directory >= 1.0.0.3, + ghc-paths >= 0.1.0.5, + filepath >= 1.1.0.2, + random >= 1.0.0.1, + process >= 1.0.1.1, + ghc >= 6.12 && < 7.0 || >= 7.0.2, + mtl >= 1.1.0.2, + containers >= 0.2.0.0, + array >= 0.2.0.0, + haskell-src-exts >= 1.9.0, + haddock >= 2.7.2, + base >= 4 && < 5, + syb >= 0.1.0.2, + time >= 1.2.0.3, + old-locale >= 1.0.0.2, + cereal >= 0.3.0.0 + + ghc-options: -threaded -fspec-constr-count=16 -rtsopts + cpp-options: -UDEBUG Other-Modules: Paths_Hs2lib, WinDll.Lib.NativeMapping,
LIMITS.txt view
@@ -1,3 +1,15 @@+Version 0.5.5 + - (Started) implementing a better test mechanism + +Version 0.5.4 + - fixed a major marshalling bug having to do with lists of pointer types. + +Version 0.5.3 + - Fixed an error with parsing pragmas + - Renamed pragma hs2c# to hs2cs + - Fixed an alignment issue with stdcall + - Fixed an issue with lists and type synonyms + Version 0.5.2 - No longer frees Strings, in order to prevent heap corruptions on calls from C#.
+ Tests/Exec/Analyze.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- This module contains code to analyze datatypes in order to generate+-- QuickCheck arbitrary instances.+--+-----------------------------------------------------------------------------++module Tests.Exec.Analyze where++import WinDll.Identifier+import WinDll.Utils.Feedback+import WinDll.Session.Hs2lib++import Tests.Exec.Structs++analyzeModule :: Exec [Arbitrary]+analyzeModule + = do modinfo <- generateMain+ return []
+ Tests/Exec/CmdArgs.hs view
@@ -0,0 +1,162 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- A module to handle commandline arguments and parsing+-- for the test generator program.+--+-----------------------------------------------------------------------------++module Tests.Exec.CmdArgs where++import WinDll.Session.Hs2lib+import Tests.Exec.Version+import WinDll.Utils.Feedback+import WinDll.Structs.Structures+import WinDll.Utils.Pragma++import System.Directory+import System.Environment+import System.FilePath+import System.Console.GetOpt+import System.Exit++import Data.Maybe+import Data.Char+import Data.List++import Control.Monad++-- | just renaming it to something that might make more sense to read in this module+type Config = Session + +-- | Default configuration set for both the client and server.+defaultConfig :: Mode -> Config+defaultConfig Windows = newSession +defaultConfig Unix = let session = newSession + in session { call = CCall }+ ++-- | The parse mode for processArgs+type Mode = Platform++-- | Read all the pragmas that contain options and then update the session with the new flags+enablePragmas :: Exec ()+enablePragmas =+ do session <- get+ inform _normal "Enabling commandline pragmas..."+ let prgmas = (pragmas.workingset) session+ cmds = getPragmas (upper_name ++ "_OPTS") prgmas+ args = mainFile session : concatMap (\(Pragma _ x)->x) cmds+ mode = platform session+ + session' <- processConversionPragmas prgmas session+ (result,errs) <- if (null args) then return (session',[]) else+ liftIO $ do (result,errs) <- processArgs session' mode args+ if (not.null) errs then putStrLn " Error(s):" else do return ()+ mapM_ (\i -> putStrLn (" -> unrecognized input '"++i++"')")) errs+ return (result,errs)+ if null errs + then put result + else die "Error processing dynamic options"++-- | Process args tries to parse the commandline arguments for either the client or the server. +-- 1 = The session to initialize things with+-- 2 = Mode to parse for+-- 3 = arguments to parse+-- return = Parsed config or error message+processArgs :: Config -> Mode -> [String] -> IO (Config, [String])+processArgs cfg mode argv= + case getOpt Permute opt argv of+ (o,n,[]) -> process (foldl (flip id) cfg o) n opt+ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header opt))+ where header = "Usage: " ++ name ++ " <input file> [OPTION...]"+ name = if mode == Windows then exename ++ ".exe" else exename+ opt = optDescr --if mode == Windows then optDescrClient else optDescrServer+ process a r opt = + case Help `elem` opts of+ True -> ioError (userError $ usageInfo header opt)+ False -> case Version `elem` opts of+ True -> putStrLn versionmsg >> exitSuccess+ + False -> case r of+ (x:[]) -> do path <- canonicalizePath (addTrailingPathSeparator (tempDIR a))+ base <- getCurrentDirectory+ abs_path <- guessPath x+ let dir = takeDirectory (normalise x)+ bin = combine base dir+ return (a { mainFile = x+ , platform = mode+ , tempDIR = path + , absPath = abs_path+ , baseDir = base+ },[])+ _ -> ioError (userError $ usageInfo header opt)+ where opts = options a+ +-- | Create a boolean flag+boolFlag :: String -> String -> (a->Bool->a) -> String -> [OptDescr (a->a)]+boolFlag short long update descr = [ template (update' True) short long descr+ , template (update' False) "" ("no"++long) [] ]+ where+ template value short long descr = Option short [long] (NoArg value) descr+ update' = flip update+ +-- | Collection of options available+optDescr = optVerbose+ : optCall + : optNamespace+ : optTempDir+ : optVersion+ : optHelp+ : optGhc+ : boolFlag "W" "warnings" (\cfg new -> cfg { warnings = new }) "print all warnings (Default True)"+ ++ boolFlag "E" "warnings-as-errors" (\cfg new -> cfg { warnings_as_errors = new+ , warnings = new || warnings cfg }) "treat all warnings as errors (Default False)"+ ++ boolFlag "T" "keep-temp-files" (\cfg new -> cfg { keep_temps = new }) "keep all the temporary files generated by the pre-processor (Default False)"+ ++ boolFlag "" "debug" (\cfg new -> cfg { debugging = new }) ("Enable debugging support which enabled memory profiling.")+ +-- | Collection of simple actions+optVerbose = Option ['v'] ["verbose","verbosity" ] (OptArg (\value cfg -> cfg { verbosity = fread (verbosity cfg) value }) "<number>") "set the verbosity level. Requires a number between 0 (off) and 3"+optCall = Option ['C'] ["convention" ] (ReqArg (\value cfg -> cfg { call = cread StdCall value }) "<StdCall | CCall>") "set the calling convention used in FFI (Default stdcall)"+optNamespace = Option ['n'] ["name" ] (ReqArg (\value cfg -> cfg { namespace = correct value }) "<name>") ("set the name to use in every generated code. (Default \"" ++ exename ++ "\")")+optTempDir = Option [ ] ["temp","temp-directory" ] (ReqArg (\value cfg -> cfg { tempDIR = value }) "<temp-directory>") "set the temporary directory of the pre-processor (Default system temp)"+optHelp = Option ['?'] ["h","help" ] (NoArg (\cfg -> cfg {options = Help:(options cfg)}) ) "Show this help screen"+optVersion = Option [ ] ["version" ] (NoArg (\cfg -> cfg {options = Version:(options cfg)}) ) "Show program version information"+optGhc = Option [ ] ["opt-ghc" ] (ReqArg (\value cfg -> cfg { optGHC = value }) "\"<options>\"") "options to pass along unmodified to ghc during main compilation."++fread :: Int -> Maybe String -> Int+fread c q = let p = maybe 1 (read' 1) q+ in if (p + c) > 3 || (c + p) < 0 then 1 else (c+p)+ +cread c q = let p = reads q+ hasValue = not $ null p+ value = if hasValue then fst $ head p else c+ in value+ +-- | Get the read in namespace name into a useable format+correct :: String -> String+correct [] = []+correct (x:xs) = toUpper x : filter isAlphaNum xs++-- | Because read can fail for parsing stuff other than strings. +-- this function is used to either accept the change. or use the default+read' :: Int -> String -> Int+read' def str = let r = reads str + in if null r then def else (fst.head) r++-- | The main parse function to call. It takes a mode as parameters and takes a pointer+-- to a function to call should it all succeed.+goArgs :: Mode -> (Config -> IO ()) -> IO ()+goArgs mode call =+ do args <- getArgs+ (result,errs) <- processArgs (defaultConfig mode) mode args+ if (not.null) errs then putStrLn " Errors:" else do return ()+ mapM_ (\i -> putStrLn (" -> unrecognized input '"++i++"')")) errs+ if null errs then call result else do return ()
+ Tests/Exec/Default.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Defines a generic producer which is able to generate values to feed to +-- QuickCheck in order to feed the test values. +-- +----------------------------------------------------------------------------- + +module Tests.Exec.Default + ( Default(..) + , geq + , Wrap(..) + , Data() + , Typeable() + , genDefault + ) where + +import Data.Data +import Data.Typeable + +import Data.Generics.Builders +import Data.Generics.Twins + +class Default phi where + nDefault :: phi + +-- | Avoid the need for Undecidable Instances +newtype Wrap a = Wrap { unWrap :: a } + +instance Data a => Default (Wrap a) where + nDefault = Wrap empty + +genDefault :: (Data a, Default (Wrap a)) => a +genDefault = unWrap nDefault +
+ Tests/Exec/Example.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Tests.Exec.Example where + +import Tests.Exec.Default + +data Expr = Mul Expr Expr + | Div Expr Expr + | Sub Expr Expr + | Add Expr Expr + | Parens Expr + | Val Int + | Var String + | Let String Expr Expr + +-- @@ Expr +printExpr :: Expr -> String +printExpr (Mul e1 e2) = printExpr e1 ++ " * " ++ printExpr e2 +printExpr (Div e1 e2) = printExpr e1 ++ " / " ++ printExpr e2 +printExpr (Sub e1 e2) = printExpr e1 ++ " - " ++ printExpr e2 +printExpr (Add e1 e2) = printExpr e1 ++ " + " ++ printExpr e2 +printExpr (Parens e) = "(" ++ printExpr e ++ ")" +printExpr (Val i) = show i +printExpr (Var str) = str +printExpr (Let v e1 e2) = "Let " ++ v ++ " = " ++ printExpr e1 ++ " in " ++ printExpr e2 + +deriving instance Data Expr +deriving instance Typeable Expr +deriving instance Eq Expr
+ Tests/Exec/Hs2lib-testgen.hs view
@@ -0,0 +1,65 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : GPL +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- The main entry file for the preprocessor +-- part of the WinDll suite +-- +----------------------------------------------------------------------------- + +module Main where + +import Tests.Exec.CmdArgs +import Tests.Exec.Analyze + +import WinDll.Session.Hs2lib +import WinDll.Utils.Feedback +import WinDll.Utils.DepScanner hiding (main) +import WinDll.Parsers.Hs2lib +import WinDll.Identifier + +import System.Info +import Control.Monad.State +import Control.Monad.Error + +-- | Determine the platform we're currently running on, so we can tweak the defaults a bit +mode :: Platform +mode = case os of + "mingw32" -> Windows + _ -> Unix + +main = goArgs mode bootstrap + +-- | Get the ball rolling on everything +bootstrap :: Config -> IO () +bootstrap cfg = + do val <- runErrorT (evalStateT mainStart cfg) + case val of + (Left str) -> fail ("Program returned error in computation: '" ++ str ++ "'") + (Right _) -> return () + +-- | Start of the main computation +mainStart :: Exec () +mainStart = do inform _normal "Program starting up..." + session <- get + + -- These lines do all the needed calculations + + traceDeps -- Read all dependencies, so we find the tree of files which need parsing + readFromFiles -- Read all datastructures from the read dependencies. + enablePragmas -- Process the enabled commandline pragmas. The other pragmas are determined later on + + -- The following lines do actual writing of outputs + value <- analyzeModule + + -- clean up + cleanup + + inform _detail "Program terminating..." + liftIO $ putStrLn "Done."
+ Tests/Exec/Structs.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- This module contains structural information on the module+--+-----------------------------------------------------------------------------++module Tests.Exec.Structs where++import WinDll.Structs.Structures++import Data.Data+import Data.Typeable++-- | A Extended version of \Datatype\ to support weighing of +-- constructors etc.+data Arbitrary = Arbitrary { arName :: Name+ , arVars :: [TypeName]+ , arCons :: DataTypes+ , arTag :: TypeTag+ } + | Variant { arCost :: Int+ , arName :: Name+ , arFix :: DataFixity+ , arNamed :: AnnWeighedTypes+ }+ deriving(Eq,Data,Typeable)+ +type AnnWeighedTypes = [AnnWeighedType]++data AnnWeighedType = AnnWeighedType { awtCost :: Int+ , awtType :: AnnType+ }+ deriving(Eq,Data,Typeable)
+ Tests/Exec/Version.hs view
@@ -0,0 +1,44 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- This module contains versioning information about the test generator tool. +-- +----------------------------------------------------------------------------- + +module Tests.Exec.Version where + +import Data.List ( intercalate ) +import Data.Char ( toUpper ) + +-- | Version Number +verNum :: [Int] +verNum = [0,0,1] + +-- | Version string +verStr :: String +verStr = (intercalate "." . map show) verNum + +-- | Product version +version :: String +version = verStr ++ " ~Experimental~" + +-- | Version message including product name +versionmsg :: String +versionmsg = exename + ++ " Build version " ++ version + ++ "\n(c) Tamar Christina <tamar@zhox.com>. 2009 - 2011." + +-- | Product name +exename :: String +exename = "Hs2lib-testgen" + +-- | Product name converted to uppercase +upper_name :: String +upper_name = map toUpper exename
WinDll/CmdArgs/Hs2lib.hs view
@@ -121,6 +121,7 @@ : optHelp : optLibmain : optIncludes+ : optGhc : boolFlag "W" "warnings" (\cfg new -> cfg { warnings = new }) "print all warnings (Default True)" ++ boolFlag "E" "warnings-as-errors" (\cfg new -> cfg { warnings_as_errors = new , warnings = new || warnings cfg }) "treat all warnings as errors (Default False)"@@ -130,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)"@@ -151,6 +152,7 @@ optVersion = Option [ ] ["version" ] (NoArg (\cfg -> cfg {options = Version:(options cfg)}) ) "Show program version information" optLibmain = Option ['L'] ["libmain" ] (ReqArg (\value cfg -> cfg { dllmain = value }) "<path>") "set the dllmain file to be used by when compiling the library" optIncForeign = Option [ ] ["native-symbols" ] (ReqArg (\value cfg -> cfg { native_symbols = value : (native_symbols cfg) }) "<path>") "include the .DEF file specified here into the final generated Exports table."+optGhc = Option [ ] ["opt-ghc" ] (ReqArg (\value cfg -> cfg { optGHC = value }) "\"<options>\"") "options to pass along unmodified to ghc during main compilation." fread :: Int -> Maybe String -> Int fread c q = let p = maybe 1 (read' 1) q
WinDll/CodeGen/C.hs view
@@ -106,7 +106,8 @@ -- | Return the size of a specified type getSize ann x = let types = createCType (annWorkingSetC ann) x args = init types - sizes = map (lookupSize (annWorkingSetCSize ann)) args + sizes = map (rnd . lookupSize (annWorkingSetCSize ann)) args + rnd m = let i = m + 3 in (i - (i `mod` 4)) -- round up to nearest mutiple of 4 in show (sum sizes) -- | Generate the C extern list from the list of functions.
WinDll/CodeGen/CSharp/CSharp.hs view
@@ -192,30 +192,31 @@ else maybe [] id (lookup ty attlist) -- | List containing mapping to C# Attributes from type -attlist ::[(String , [Attr] )]-attlist = [("String" , mk "LPWStr" )- ,("char*" , [] )- ,("Int" , [] )- ,("Int8" , mk "SByte" )- ,("Int16" , mk "I2" )- ,("Int32" , mk "I4" )- ,("Int64" , mk "I8" )- ,("Word8" , mk "U1" )- ,("Word16" , mk "U2" )- ,("Word32" , mk "U4" )- ,("Word64" , mk "U8" )- ,("Float" , [] )- ,("Double" , [] )- ,("CWString" , mk "LPWStr" )- ,("CInt" , mk "I4" )- ,("Bool" , mk "I1" )- ,("FastString" , mk "LPWStr" )- ,("FastInt" , mk "I4" )- ,("Char" , [] )- ,("CWchar" , [] )- ,("CChar" , [] )- ,("Integer" , mk "I8" )- ,("Rational" , mk "I8" )- ,("StablePtr" , [] )- ,("()" , [] )]+attlist ::[(String , [Attr] )]+attlist = [("String" , mk "LPWStr" )+ ,("StringBuilder", mk "LPWStr" )+ ,("char*" , [] )+ ,("Int" , [] )+ ,("Int8" , mk "SByte" )+ ,("Int16" , mk "I2" )+ ,("Int32" , mk "I4" )+ ,("Int64" , mk "I8" )+ ,("Word8" , mk "U1" )+ ,("Word16" , mk "U2" )+ ,("Word32" , mk "U4" )+ ,("Word64" , mk "U8" )+ ,("Float" , [] )+ ,("Double" , [] )+ ,("CWString" , mk "LPWStr" )+ ,("CInt" , mk "I4" )+ ,("Bool" , mk "I1" )+ ,("FastString" , mk "LPWStr" )+ ,("FastInt" , mk "I4" )+ ,("Char" , [] )+ ,("CWchar" , [] )+ ,("CChar" , [] )+ ,("Integer" , mk "I8" )+ ,("Rational" , mk "I8" )+ ,("StablePtr" , [] )+ ,("()" , [] )] where mk x = [Attr Cs.Normal "MarshalAs" ["UnmanagedType." ++ x]]
WinDll/CodeGen/Haskell.hs view
@@ -76,14 +76,20 @@ stables = modStablePtrs modInfo debug = debugging session + (simple_datatypes, spec_datatypes) = modDatatypes modInfo -- Code from pragmas- cmds = getPragmas "IMPORT" ((pragmas.workingset) session)- prag_imps = map Import $ concatMap (\(ST.Pragma _ x)->x) cmds+ pragmaBuf = (pragmas.workingset) session+ cmds0 = getPragmas "IMPORT" pragmaBuf+ prag_imps = map Import $ concatMap (\(ST.Pragma _ x)->x) cmds0 - cmds' = getPragmas "INSTANCE" $ (pragmas.workingset) session- args = map (\(ST.Pragma _ x)->unwords x) cmds'+ cmds1 = getPragmas "INSTANCE" pragmaBuf+ args = map (\(ST.Pragma _ x)->unwords x) cmds1+ + cmds2 = getPragmas "LANGUAGE" pragmaBuf+ langs = concatMap (\(ST.Pragma _ x)-> x) cmds2+ mkType' x = let (y:n:_) = words x -- TODO: this is unsafe, fix it ns = read n typenames = zipWith (flip (++).show) [1..ns] (repeat "a")@@ -104,7 +110,8 @@ ,Pragma LANGUAGE "TypeSynonymInstances" ,Pragma LANGUAGE "FlexibleInstances" ,Pragma LANGUAGE "MultiParamTypeClasses"- ] ++ if debug then [Pragma LANGUAGE "CPP"] else [])+ ] ++ if debug then [Pragma LANGUAGE "CPP"] else []+ ++ map (Pragma LANGUAGE) langs) (imp ++ map Import deps ++ prag_imps) lets [LocalInclude (name++".h")
WinDll/Identifier.hs view
@@ -31,6 +31,8 @@ import WinDll.Structs.Structures import WinDll.Utils.Feedback import WinDll.Utils.Types (simplify) +import WinDll.Utils.KnownTypes +import WinDll.Utils.ListTypes import WinDll.Builder import WinDll.Parsers.Hs2lib import WinDll.Session.Hs2lib @@ -61,7 +63,9 @@ Nothing -> do let _modules = ((map fst) . modules . workingset) session - merged@(Module _ _ _ _ d f _ t) = subject args $ fixpoint (mergeModules _modules) + merged@(Module _ _ _ _ d f _ t) = updateModule + $ subject args + $ fixpoint (mergeModules _modules) (simple_datatypes, spec_datatypes) = partition isSimpleData d (t_mods,missing,spec) = traceModules spec_datatypes imps merged @@ -386,25 +390,6 @@ -- | Lookup typing information using GHC API, in order to find out whether the type is a custom defined type, or a primitive type. lookupType :: Type -> Maybe Type lookupType _type = undefined - --- | A list of the most frequently used types, It's much faster to do list lookup than query GHC, --- so we first look up in this list and then make a call to GHC -knownPrimitives :: TypeNames -knownPrimitives = [ "Int" , "Integer", "Float" , "Double" , "String" , "Char" ,"Word64" - , "Int8" , "Int16" , "Int32" , "Int64" , "Word8" , "Word16" ,"Word32" - , "Int#" , "Float#" , "Double#" , "CWString" , "Bool" , "IO" , "()" - , "CInt" - ] ++ knownPointerTypes - --- | A list of known pointer types, if we find these we should not trace their dependencies. --- because they matter not. -knownPointerTypes :: TypeNames -knownPointerTypes = ["StablePtr", "Ptr"] - --- | The first lookup venue to GHC is looking up based on the type classes that we've already covered by the FFI class. --- So if the type is an instance of the following classes it's safe to ignore them. -knownClasses :: TypeNames -knownClasses = ["Storable" , "IO" , "Num" , "FFIType" ] -- askGHC :: [Types] -> IO [String] -- askGHC
WinDll/Lib/Native.hs view
@@ -74,21 +74,21 @@ -- | List of type conversion from C/C++ to C# types nativeC2cslist :: [(String , String )] nativeC2cslist = [("wchar_t*" , "char*" ) - ,("int" , "int" ) - ,("int8_t" , "SByte" ) - ,("int16_t" , "Int16" ) - ,("int32_t" , "Int32" ) - ,("int64_t" , "Int64" ) - ,("uint8_t" , "Byte" ) - ,("uint16_t" , "UInt16" ) - ,("uint32_t" , "UInt32" ) - ,("uint64_t" , "UInt64" ) - ,("float" , "float" ) - ,("double" , "double" ) - ,("wchar_t" , "char" ) - ,("void*" , "void*" ) - ,("void" , "void" ) - ,("long long int" , "long" )] + ,("int" , "int" ) + ,("int8_t" , "SByte" ) + ,("int16_t" , "Int16" ) + ,("int32_t" , "Int32" ) + ,("int64_t" , "Int64" ) + ,("uint8_t" , "Byte" ) + ,("uint16_t" , "UInt16" ) + ,("uint32_t" , "UInt32" ) + ,("uint64_t" , "UInt64" ) + ,("float" , "float" ) + ,("double" , "double" ) + ,("wchar_t" , "char" ) + ,("void*" , "void*" ) + ,("void" , "void" ) + ,("long long int" , "long" )] -- | List containing mapping to C# Types nativeCslist :: Bool -> [(String , String )] @@ -117,7 +117,7 @@ ,("StablePtr" , "IntPtr" ) ,("IntPtr" , "IntPtr" ) ,("()" , "void" )] - where str = if struct then "char*" else "String" + where str = if struct then "char*" else "StringBuilder" -- | List containing mapping to CSizes nativeC_sizes ::[(String , Int)]
WinDll/Lib/NativeMapping_Base.cpphs view
@@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE EmptyDataDecls #-} @@ -235,9 +235,9 @@ -- TODO: Can this even be defined using the native functions? -- This instance can't be generated. It'll stay here for now, buy it can only -- 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)) +-- 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)) -- | I decided to use a CAString because on windows this gives me a constant 16 value instance FFIType String CWString where @@ -251,7 +251,7 @@ -- | Intermediate conversion instance for storing values of arrays instance (Storable a, FFIType b a) => FFIType [b] (Ptr a) where - toNative _ST_ = (RECORDM(__FILE__, __LINE__, "newArray", (\val -> newArray =<< mapM (toNative _ST_) val))) _ST_ + toNative _ST_ = (RECORDM(__FILE__, __LINE__, "newArray", (\val -> newArray =<< mapM (toNative _ST_ $!) val))) _ST_ fromList _ST_ x ptr = do {(RECORD(__FILE__, __LINE__, "peekArray", id)) _ST_ ptr; i <- fromNative _ST_ x; v <- peekArray i ptr; @@ -365,6 +365,12 @@ poke ptr value = do newptr <- newArray value #endif copyArray (castPtr ptr) newptr (length value) +#ifdef DEBUG + (FREE(__FILE__, __LINE__, "freeArray", F.free)) emptyStack undefined ptr +#else + F.free ptr +#endif + peekElemOff ptr c = do val <- peekArray c (castPtr ptr) #ifdef DEBUG (FREE(__FILE__, __LINE__, "freeArray", F.free)) emptyStack undefined ptr @@ -380,9 +386,9 @@ -- | Instance for Functor classes -- TODO: rewrite this. -instance (Functor f, FFIType a b) => FFIType (f a) (f b) where - toFFI _ST_ = fmap (toFFI _ST_) - fromFFI _ST_ = fmap (fromFFI _ST_) +-- instance (Functor f, FFIType a b) => FFIType (f a) (f b) where + -- toFFI _ST_ = fmap (toFFI _ST_) + -- fromFFI _ST_ = fmap (fromFFI _ST_) -- -- | Instance for Functor classes directly to pointers {- instance (Functor f, FFIType a b,Storable (f b)) => FFIType (f a) (Ptr (f b)) where
WinDll/Parsers/Hs2lib.hs view
@@ -103,9 +103,10 @@ -- . {- @@ INSTANCE <name> <count> @@ -} -=- generate type info required to work correctly but also hides the warning of missing data definition -- . {- @@ IMPORT <list> @@ -} -=- Imports to carry over to the new generated module -- . {- @@ HS2C <htype> <type>@<size> @@ -} -=- Specifies what to translate the Haskell htype to the C type, but we also need its size in bytes--- . {- @@ HS2C# <htype> <c#type> @@ -} -=- Specifies what to translate the Haskell htype to the C# type, but we also need its size in bytes+-- . {- @@ 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 [] = []@@ -274,11 +275,10 @@ fixC = map (\(c,d)->(map prep c,d)) createFunction :: CommentDecl -> Function- createFunction (p,(TypeSig _ name' typ')) = Function name (tlength typ - 1) ty ann typ+ createFunction (p,(TypeSig _ name' typ')) = Function name (tlength typ - 1) typ newAnn 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 @@ -294,9 +294,8 @@ mkName (Exts.Symbol s) = s createExport :: CommentDecl -> Export- createExport (p,(TypeSig _ name' _type)) = Export name exportn ty typ modname+ createExport (p,(TypeSig _ name' _type)) = Export name exportn typ 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@@ -330,13 +329,11 @@ -- | 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+genFreeVars nm f n (x:xs) = let ann = noAnn+ t = getTypeFromBang x+ name = (f.show) n+ ann' = ann{ annModule = nm }+ value = AnnType name t ann' t nm in value : genFreeVars nm f (n+1) xs -- | Strip a layer away and get to the real type.@@ -348,20 +345,12 @@ -- | 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+genNamedVars n (((x:_),a):xs) = let ann = noAnn + ann' = ann{ annModule = n }+ ty = getTypeFromBang a+ name = head $ findStrings x+ value = 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]@@ -397,185 +386,6 @@ 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
WinDll/Session/Hs2lib.hs view
@@ -132,6 +132,7 @@ , workingset :: WorkingSet -- ^ @workingset@ The current working set for the project , pipeline :: Builder -- ^ @pipeline@ Contains cleanup information needed when program is exiting , include_foreigns :: Bool -- ^ @include_foreigns@ re-expose foreign declarations found when analyzing modules.+ , optGHC :: String -- ^ @optGHC@ Extra options to pass along to ghc , native_symbols :: [FilePath] -- ^ @native_symbols@ The list of Native Symbols to include in the generated .DEF files. } deriving Show@@ -219,6 +220,7 @@ , threaded = False , options = [] , includes = []+ , optGHC = [] , native_symbols = [] , workingset = WorkingSet { dependencies = [] , modules = []
WinDll/Structs/MShow/Haskell.hs view
@@ -22,6 +22,7 @@ import WinDll.Structs.C import WinDll.Structs.MShow.Alignment import WinDll.Parsers.Hs2lib+import WinDll.Utils.ListTypes import WinDll.Session.Hs2lib(addParen) @@ -69,33 +70,37 @@ instance MShow HaskellFunction where mshow (HaskellFunction name orign typ ann _orig) = - let line1 = name ++ " :: " ++ mshowM 3 resTy -- (translatePartial typ)- resTy = (mkIO $ translatePartial (annWorkingSet ann) typ)- arity = tlength typ - 1 -- last argument is result type not an actual argument- vars' = ["a"++show x|x<- [1..arity]]- isList = (arity - 1) `elem` idx- vars = if isList- then init vars'- else vars'- size = last vars'- debug = annDebug ann- pokesz = "poke " ++ size ++ " (toFFI " ++ st ++ "$! length res)"- idx = annArrayIndices ann- front = unwords [name, unwords vars',"="]- indent = (replicate 5 ' ' ++) -- (replicate (length front) ' ' ++)- lines = munch mkFFI debug ((arity - 1) `delete` idx) vars- inner = ((maximum $ map (length.fst) lines)) `max` 3- binds = map (indent . (\(l,v) -> unwords [l ++ replicate (inner - length l - 1) ' ', "<-", v])) lines- names = map fst lines- res = if isIO typ- then ["res" ++ replicate (inner - 3) ' ', "<-", orign] ++ names- else ["let res =", orign] ++ names- ret = "toNative " ++ st ++ "res"- st = if debug then "st " else ""- defs = map indent $ [unwords res] ++ if isList then [pokesz, ret] else [ret]- dbgDef = if debug - then [indent $ "let st = newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(" ++ name ++ ")\")"]- else []+ let line1 = name ++ " :: " ++ mshowM 3 resTy -- (translatePartial typ)+ resTy = (mkIO $ translatePartial (annWorkingSet ann) typ)+ arity = tlength typ - 1 -- last argument is result type not an actual argument+ vars' = ["a"++show x|x<- [1..arity]]+ isList = (arity - 1) `elem` idx+ vars = if isList+ then init vars'+ else vars'+ size = last vars'+ debug = annDebug ann+ pokesz = [(st `add` "s") ++ " <- toNative " ++ st ++ "$! length res"+ ,"poke " ++ size ++ " " ++ (st `add` "s")+ ]+ trim x = filter (/=' ') x+ add x y = trim x ++ trim y+ idx = annArrayIndices ann+ front = unwords [name, unwords vars',"="]+ indent = (replicate 5 ' ' ++) -- (replicate (length front) ' ' ++)+ lines = munch mkFFI debug ((arity - 1) `delete` idx) vars+ inner = ((maximum $ map (length.fst) lines)) `max` 3+ binds = map (indent . (\(l,v) -> unwords [l ++ replicate (inner - length l - 1) ' ', "<-", v])) lines+ names = map fst lines+ res = if isIO typ+ then ["res" ++ replicate (inner - 3) ' ', "<-", orign] ++ names+ else ["let res =", orign] ++ names+ ret = "toNative " ++ st ++ "res"+ st = if debug then "st " else ""+ defs = map indent $ [unwords res] ++ if isList then pokesz ++ [ret] else [ret]+ dbgDef = if debug + then [indent $ "let st = newStack (__FILE__ ++ \":\" ++ (show __LINE__) ++ \"(" ++ name ++ ")\")"]+ else [] in unlines $ [line1,front] ++ addDo (dbgDef ++ binds ++ defs) where addDo :: [String] -> [String] addDo [] = [" do "]@@ -128,7 +133,7 @@ then let (a:xs) = l st1 = mkBinds dbg "st" "toNative" st2 = mkBinds dbg "st" "toNative" - in ([(a++"sp", mkDbgSym dbg st1 "toNative " ++ "$ length "++a)+ in ([(a++"sp", mkDbgSym dbg st1 "toNative " ++ "$! length "++a) ,(a++ "p", mkDbgSym dbg st2 "toNative " ++ a)], xs, (+1)) else let (a:xs) = l st = mkBinds dbg "st" "toNative"@@ -172,19 +177,23 @@ else vars' size = last vars' debug = annDebug ann- pokesz = "poke " ++ size ++ " (toFFI " ++ st ++ "$! length res)"+ pokesz = [(st `add` "s") ++ " <- toNative " ++ st ++ "$! length res"+ ,"poke " ++ size ++ " $! " ++ (st `add` "s")+ ] ret = "toNative " ++ st ++ "res" ret2 = if isList && not origIO then mkDbg debug "fromNative " ++ "(lld res)" else mkDbg debug "fromNative " ++ "res" mkUsf b = if not b then (++" unsafePerformIO $") else id transtyIO = isIO transty origIO = isIO orig st = if debug then "st " else ""+ trim x = filter (/=' ') x+ add x y = trim x ++ trim y in unlines $ ["instance FFIType " ++ mshowM 2 (addParen orig) ++ " " ++ name ++ "Ptr where"- ," toNative " ++ st ++ "x = mk" ++ name ++ " (toFFI " ++ st ++ "x)"- ," fromFFI " ++ st ++ "x = fromFFI " ++ st ++ "(dyn" ++ name ++ " x)"+ ," toNative " ++ st ++ "x = mk" ++ name ++ " =<< toNative " ++ st ++ "x"+ ," fromNative " ++ st ++ "x = fromNative " ++ st ++ "(dyn" ++ name ++ " x)" ," freeFFI " ++ st ++ "x = freeHaskellFunPtr "- ] ++ if null (annArrayIndices ann) then []+ ] ++ if False then [] -- null (annArrayIndices ann) then [] else ["" ,"instance FFIType " ++ mshowM 2 (addParen orig) ++ " " ++ mshowM 3 (addParen transty) ++ " where" ,unlines $ (unwords $ (" toFFI " ++ st ++ "f") : vars' ++ [mkUsf transtyIO "="]) : mkResult mkFFI vars ret pokesz isList transtyIO idx' True@@ -203,7 +212,7 @@ res = if io && sat then ["res" ++ replicate (inner - 3) ' ', "<- f"] ++ names else ["let res = f"] ++ names- defs = map indent $ [unwords res] ++ if lst then [pk, rt] else [rt]+ defs = map indent $ [unwords res] ++ if lst then pk ++ [rt] else [rt] in addDo (binds ++ defs) instance MShow Include where
WinDll/Structs/MShow/HaskellSrcExts.hs view
@@ -17,6 +17,7 @@ import WinDll.Structs.MShow.MShow import WinDll.Structs.Folds.HaskellSrcExts import WinDll.Structs.Types+import WinDll.Utils.KnownTypes -- import WinDll.Utils.Types import qualified Language.Haskell.Exts as Exts@@ -25,6 +26,8 @@ import Data.List +import qualified Debug.Trace as D+ instance MShow Exts.Name where mshow (Exts.Ident s) = s mshow (Exts.Symbol s) = s@@ -106,7 +109,7 @@ fold f (Exts.TyInfix a b c) = (fold f a) ++ " " ++ mshow b ++ " " ++ (fold f c) fold f (Exts.TyKind a b) = const (fold f a) b - mshowM 4 = fold True+ mshowM 4 = fold True where fold f (Exts.TyForall a b c) = (const . const id) a b (fold f c) fold f (Exts.TyFun a b) = (fold f a) ++" -> "++ (fold f b)@@ -114,14 +117,18 @@ True -> showTuple a b (fold f) False -> prettyPrint t fold f t@(Exts.TyList a) = case f of- True -> "(Ptr ("++ (fold f a) ++ "))"+ True -> "(Ptr ("++ (fold (isPrime a) a) ++ "))" False -> prettyPrint t fold f (Exts.TyApp a b) = let name = (fold True a) in case name of "IO" -> name ++ " (" ++ fold f b ++ ")"- _ -> "(" ++ name ++ " " ++ fold False b ++ ")"+ _ | isPrime a || "Ptr" `isSuffixOf` name+ -> "(" ++ name ++ " " ++ fold (not $ isList b) b ++ ")"+ | otherwise -> "(" ++ name ++ " " ++ fold False b ++ ")" fold f (Exts.TyVar a) = mshow a- fold f (Exts.TyCon a) = mshow a+ fold f (Exts.TyCon a) = case f of+ True -> mshow a+ False -> "(Ptr " ++ mshow a ++ ")" fold f (Exts.TyParen a) = "(" ++ (fold f a) ++ ")" fold f (Exts.TyInfix a b c) = (fold f a) ++ " " ++ mshow b ++ " " ++ (fold f c) fold f (Exts.TyKind a b) = const (fold f a) b@@ -132,6 +139,21 @@ isList (Exts.TyList _) = True isList (Exts.TyParen a) = isList a isList _ = False++-- | Checks to see if the given type is a constructor. Also checks in Parens+isCon :: Type -> Bool+isCon (Exts.TyCon _) = True+isCon (Exts.TyParen a) = isCon a+isCon _ = False++-- | checks to see if a type is part of the known list of primitives+isPrime :: Type -> Bool+isPrime ty = if isCon ty+ then (take ty) `elem` knownPrimitives+ else False+ where take :: Type -> TypeName+ take (Exts.TyParen a) = take a+ take x = prettyPrint x -- | Checks to see if the given type is a function. Also checks in Parens isFun :: Type -> Bool
WinDll/Structs/Structures.hs view
@@ -87,9 +87,20 @@ -- | Datatype and Newtype declarations Tagged with some extra information -- like the full type name. This is needed because the declarations will be -- processed independently of their module declarations. So this information is needed -data DataType = DataType Name [TypeName] DataTypes TypeTag - | NewType Name [TypeName] DataType TypeTag - | Constr Name DataFixity AnnNamedTypes +data DataType = DataType { dtName :: Name + , dtVars :: [TypeName] + , dtCons :: DataTypes + , dtTag :: TypeTag + } + | NewType { dtName :: Name + , dtVars :: [TypeName] + , dtCon :: DataType + , dtTag :: TypeTag + } + | Constr { dtName :: Name + , dtFix :: DataFixity + , dtNamed :: AnnNamedTypes + } deriving(Eq,Data,Typeable) -- | The fixity of the constructor
+ WinDll/Utils/KnownTypes.hs view
@@ -0,0 +1,36 @@+-----------------------------------------------------------------------------+-- |+-- Module : Windll+-- Copyright : (c) Tamar Christina 2009 - 2010+-- License : BSD3+-- +-- Maintainer : tamar@zhox.com+-- Stability : experimental+-- Portability : portable+--+-- This modules contains the list of known primitive types. This is one of the+-- the lists that needs expanding in order to add new native types.+--+-----------------------------------------------------------------------------+module WinDll.Utils.KnownTypes where++import WinDll.Structs.Types++-- | A list of the most frequently used types, It's much faster to do list lookup than query GHC, +-- so we first look up in this list and then make a call to GHC+knownPrimitives :: TypeNames+knownPrimitives = [ "Int" , "Integer", "Float" , "Double" , "String" , "Char" ,"Word64"+ , "Int8" , "Int16" , "Int32" , "Int64" , "Word8" , "Word16" ,"Word32"+ , "Int#" , "Float#" , "Double#" , "CWString" , "Bool" , "IO" , "()"+ , "CInt" + ] ++ knownPointerTypes++-- | A list of known pointer types, if we find these we should not trace their dependencies.+-- because they matter not.+knownPointerTypes :: TypeNames+knownPointerTypes = ["StablePtr", "Ptr"]+ +-- | The first lookup venue to GHC is looking up based on the type classes that we've already covered by the FFI class.+-- So if the type is an instance of the following classes it's safe to ignore them.+knownClasses :: TypeNames+knownClasses = ["Storable" , "IO" , "Num" , "FFIType" ]
+ WinDll/Utils/ListTypes.hs view
@@ -0,0 +1,231 @@+----------------------------------------------------------------------------- +-- | +-- Module : Windll +-- Copyright : (c) Tamar Christina 2009 - 2010 +-- License : BSD3 +-- +-- Maintainer : tamar@zhox.com +-- Stability : experimental +-- Portability : portable +-- +-- Various functions to detect and record list types within a +-- given type. +-- +----------------------------------------------------------------------------- + +module WinDll.Utils.ListTypes where + +import qualified Language.Haskell.Exts as Exts + +import Data.Generics +import Data.List + +import WinDll.Structs.Structures hiding (Module) +import qualified WinDll.Structs.Structures as WinDll +import WinDll.Structs.MShow.HaskellSrcExts +import WinDll.Structs.Folds.HaskellSrcExts +import WinDll.Utils.Types + +-- | 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 + +-- | 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 + +updateModule :: WinDll.Module -> WinDll.Module +updateModule = everywhere (mkT mkFunction `extT` mkExport `extT` mkDataType) + where mkFunction e@(WinDll.Function{}) = let (newAnn, ty) = upgradeType (fnAnn e) (fnType e) + in e{fnType = ty, fnAnn = newAnn } + mkExport e@(WinDll.Export{} ) = let (_, ty) = upgradeType noAnn (exType e) + in e{exType = ty} + mkDataType e@(WinDll.DataType{}) = let dt = dtCons e + in e{dtCons = map mkConstr dt} + mkDataType e@(WinDll.NewType{} ) = let dt = dtCon e + in e{dtCon = mkConstr dt} + mkDataType e = e + mkConstr e@(WinDll.Constr{} ) = let dt = dtNamed e + in e{dtNamed = map mkAnnNamedTypes dt} + mkAnnNamedTypes e@(AnnType{} ) = let (newAnn, ty) = upgradeType (antAnn e) (antType e) + ann' = newAnn{annArrayIsList = True, annArrayIndices = []} + in case isOnlyList (antType e) of + False -> e{antType = ty, antAnn = newAnn} + True -> e{antAnn = ann'}
WinDll/Utils/Pragma.hs view
@@ -31,7 +31,7 @@ -- consists of two strings seperated by a @ sign. validate :: String -> Pragma -> Exec Pragma validate mask p@(Pragma nm ld) - = do guard (not $ isValid (words mask) ld) >> + = do when (not $ isValid (words mask) ld) (die $ "Syntax error in Pragma " ++ nm ++ ", supplied value '" ++ unwords ld ++ "' does not match mask '" ++ mask ++ "'") return p @@ -51,10 +51,12 @@ -- proper conversion sets processConversionPragmas :: [Pragma] -> Session -> Exec Session processConversionPragmas prg session - = do hs2c <- mapM (validate "# #@#") $ getPragmas "HS2C" prg - hs2cs <- mapM (validate "# #" ) $ getPragmas "HS2C#" prg + = do inform _detail "Validating pragmas..." + hs2c <- mapM (validate "# #@#") $ getPragmas "HS2C" prg + hs2cs <- mapM (validate "# #" ) $ getPragmas "HS2CS" prg hs2hs <- mapM (validate "# #" ) $ getPragmas "HS2HS" prg + inform _detail "Updating session..." put session updateFromPragma hs2c updt1 (\x y->y{n_hs2c =x ++ nativeLisths2c}) updateFromPragma hs2c updt2 (\x y->y{n_csize=x ++ nativeC_sizes})
WinDll/Utils/Processes.hs view
@@ -145,6 +145,7 @@ fullfile = dirPath build os = platform session dir = baseDir session+ extras = optGHC session return (output,["-fglasgow-exts" ,"--make" ] @@ -169,6 +170,10 @@ ,"-funfolding-use-threshold=16" ,"-optc-O3" ,"-optc-ffast-math"+ ]+ ++ if null extras then [] else [extras] +++ [+ -- ,"-debug" -- ,"-fno-full-laziness" -- due to calls to unsafePerformIO -- ,"-fno-cse" -- prevent any cse to be performed. -- ,"-prof"
WinDll/Version/Hs2lib.hs view
@@ -19,7 +19,7 @@ -- | Version Number verNum :: [Int] -verNum = [0,5,2] +verNum = [0,5,5] -- | Version string verStr :: String