hubris 0.0.2 → 0.0.3
raw patch · 10 files changed
+101/−191 lines, 10 filessetup-changed
Files
- Hubrify.hs +21/−21
- Includes.hs +0/−2
- Language/Ruby/Hubris.hs +24/−16
- Language/Ruby/Hubris/Binding.chs +3/−75
- Language/Ruby/Hubris/GHCBuild.hs +13/−48
- Language/Ruby/Hubris/LibraryBuilder.hs +8/−5
- Setup.hs +17/−5
- cbits/rshim.c +9/−4
- cbits/rshim.h +2/−2
- hubris.cabal +4/−13
Hubrify.hs view
@@ -2,14 +2,9 @@ import Language.Ruby.Hubris.LibraryBuilder import System import System.Exit-import Control.Monad(when)-import Language.Ruby.Hubris.ZCode (zenc,zdec) -+-- import Control.Monad (when) import System.Console.GetOpt-import Data.Maybe ( fromMaybe ) -- data Options = Options { optVerbose :: Bool , optStrict :: Bool@@ -20,49 +15,54 @@ , optPackages :: [String] } deriving Show +defaultOptions :: Options defaultOptions = Options { optVerbose = False , optShowVersion = False+ , optOutput = error "output must be defined"+ , optModule = error "module must be defined" , optStrict = False , optInput = Nothing- , optPackages = []+ , optPackages = [] } options :: [OptDescr (Options -> Options)] options =- [ Option ['v'] ["verbose"]- (NoArg (\ opts -> opts { optVerbose = True }))+ [ Option "v" ["verbose"]+ (NoArg (\opts -> opts { optVerbose = True })) "chatty output on stderr" , Option [] ["strict"]- (NoArg (\ opts -> opts { optStrict = True }))+ (NoArg (\opts -> opts { optStrict = True })) "bondage and discipline mode"- , Option ['o'] ["output"]- (ReqArg ((\ f opts -> opts { optOutput = f })) "libFile")+ , Option "o" ["output"]+ (ReqArg (\f opts -> opts { optOutput = f }) "libFile") "output FILE"- , Option ['m'] ["module"]- (ReqArg ((\ f opts -> opts { optModule = f })) "module")+ , Option "m" ["module"]+ (ReqArg (\f opts -> opts { optModule = f }) "module") "module to be wrapped"- , Option ['p'] ["package"]- (ReqArg (\ d opts -> opts { optPackages = optPackages opts ++ [d] }) "DIR")+ , Option "p" ["package"]+ (ReqArg (\d opts -> opts { optPackages = optPackages opts ++ [d] }) "DIR") "package" ] hubrisOpts :: [String] -> IO (Options, [String]) hubrisOpts argv = case getOpt Permute options argv of- (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)- (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options)) where header = "Usage: Hubrify --module MODULE --output LIBFILE (--packages PACKAGE1 ...) sourceFiles ..." +main :: IO () main = do- (o,srcs) <- getArgs >>= hubrisOpts+ (o, srcs) <- getArgs >>= hubrisOpts -- HACK this may be the worst thing ever let ghcArgs = if optStrict o- then ["-Wall", "-Werror","-fno-warn-unused-imports"]+ then ["-Wall", "-Werror", "-fno-warn-unused-imports"] else [] -- putStrLn $ show $ optPackages o- res <- generateLib (optOutput o) srcs (optModule o) ghcArgs (optPackages o)++ res <- generateLib (optOutput o) srcs (optModule o) ("-fPIC":ghcArgs) (optPackages o) -- when (optVerbose o) (putStr $unlines msgs) -- print res
− Includes.hs
@@ -1,2 +0,0 @@-module Includes where-extraIncludeDirs=["/opt/local/include/ruby-1.9.1"]
Language/Ruby/Hubris.hs view
@@ -1,13 +1,13 @@ {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-} module Language.Ruby.Hubris where -import Data.Word+--import Data.Word import Data.Map as Map -- import Language.Ruby.Hubris.Binding-import System.IO.Unsafe (unsafePerformIO)-import Foreign.C.Types+-- import System.IO.Unsafe (unsafePerformIO)+--import Foreign.C.Types import Language.Ruby.Hubris.Binding-import Control.Monad (forM)+--import Control.Monad (forM) import Control.Applicative import Debug.Trace import Foreign.C.String@@ -22,24 +22,30 @@ import Prelude hiding(catch) import Monad hiding (when) import Data.Typeable--wrap :: (Haskellable a, Show b, Rubyable b) => (a->b) -> (Value -> Value)+ +wrap :: (Haskellable a, Rubyable b) => (a->b) -> (Value -> Value) wrap func v= unsafePerformIO $ do r <- try (evaluate $ toRuby . func $ toHaskell v) case r of- Left (e::HubrisException) -> createException "Blah" `traces` "died in haskell"+ Left (_e::HubrisException) -> createException "Blah" `traces` "died in haskell" Right a -> return a-+-- wrapIO too? Is there a more generic way of doing this? would need a = a', b = IO c, so Rubyable b => Rubyable (IO c). (Throw away Show constraint, not necessary)+ data HubrisException = HubrisException deriving(Show, Typeable) + instance Exception HubrisException -- utility stuff:+sshow :: S.ByteString -> [Char] sshow s = Prelude.map w2c $S.unpack s+lshow :: L.ByteString -> [Char] lshow s = Prelude.map w2c $L.unpack s---traces = flip trace-traces a b = a +traces :: b -> String -> b+traces = flip trace++when :: Value -> RubyType -> a -> a when v b c = if (rubyType v == b) then c else throw HubrisException@@ -57,14 +63,16 @@ instance Rubyable Int where toRuby i = int2fix i +instance Rubyable a => Rubyable (IO a) where+ toRuby a = unsafePerformIO (a >>= return . toRuby) instance Haskellable Integer where toHaskell v = case rubyType v of- RT_BIGNUM -> read $ unsafePerformIO (rb_big2str v 10 >>= str2cstr >>= peekCString)- RT_FIXNUM -> fromIntegral $ fix2int v+ RT_BIGNUM -> trace ("got a big") $ read $ unsafePerformIO (rb_big2str v 10 >>= str2cstr >>= peekCString)+ RT_FIXNUM -> trace("got a fix") $ fromIntegral $ fix2int v _ -> throw HubrisException -- wonder if it's kosher to just let the pattern match fail... -instance Rubyable Integer where- toRuby i = rb_str_to_inum (unsafePerformIO $ (newCAString $ show i) >>= rb_str_new2) 10 1+instance Rubyable Integer where+ toRuby i = trace ("integer to ruby") $ rb_str_to_inum (unsafePerformIO $ (newCAString $ show i) >>= rb_str_new2) 10 1 instance Haskellable Bool where toHaskell v = case rubyType v of@@ -102,7 +110,8 @@ \(cs,len) -> rb_str_new (cs,len) `traces` ("sstrict back to ruby:" ++ (show $ S.unpack s)) -+instance Rubyable () where+ toRuby () = toRuby True -- ??? instance Haskellable L.ByteString where toHaskell v = L.fromChunks [toHaskell v]@@ -195,4 +204,3 @@ -- get_each -- toHaskell _ = Nothing-
Language/Ruby/Hubris/Binding.chs view
@@ -38,8 +38,8 @@ constToRuby :: RubyConst -> Value constToRuby = fromIntegral . fromEnum --#if RUBY_VERSION_CODE <= 187+-- RUBY_VERSION_CODE <= 187+#if 1 data RubyConst = RUBY_Qfalse | RUBY_Qtrue | RUBY_Qnil @@ -55,6 +55,7 @@ toEnum 2 = RUBY_Qtrue toEnum 4 = RUBY_Qnil toEnum 6 = RUBY_Qundef+ toEnum 12 = RUBY_Qnil #else {# enum ruby_special_consts as RubyConst {} deriving (Eq,Show) #} #endif@@ -97,79 +98,6 @@ createException :: String -> IO Value createException s = newCAString s >>= buildException -- ("puts HaskellError.methods(); HaskellError.new") >>= rb_eval_string------ data RValue = T_NIL --- | T_FLOAT Double--- | T_STRING Value---- -- List is non-ideal. Switch to uvector? Array? There's always going--- -- to be an extraction step to pull the RValues out.--- | T_ARRAY [RValue]--- | T_FIXNUM Int --- | T_HASH Value -- Int -- definitely FIXME - native ruby hashes, or going to transliterate into Data.Map?--- | T_BIGNUM Integer ---- -- technically, these are mapping over the types True and False,--- -- I'm going to treat them as values, though.--- | T_TRUE --- | T_FALSE --- | T_OBJECT Value--- | T_CLASS Value--- -- | T_EXCEPTION String--- | T_SYMBOL Word -- interned string--- deriving (Eq, Show)--- These are the other basic Ruby structures that we're not handling yet.--- | T_REGEXP --- | T_FILE--- | T_STRUCT --- | T_DATA ----- | T_MODULE --- -- leaky as hell--- fromRVal :: RValue -> Value--- fromRVal r = case r of--- T_FLOAT d -> rb_float_new d--- -- need to take the address of the cstr, just cast it to a value--- -- sadly no bytestrings yet - unpack it to a list. yeah it's ugly.--- T_STRING str -> str -- unsafePerformIO $ newCAString str >>= rb_str_new2--- T_FIXNUM i -> int2fix i---- -- so this is just bizarre - there's no boolean type. True and False have their own types--- -- as well as their own values.--- T_TRUE -> constToRuby RUBY_Qtrue--- T_FALSE -> constToRuby RUBY_Qfalse--- T_NIL -> constToRuby RUBY_Qnil--- T_HASH h -> h--- T_ARRAY l -> unsafePerformIO $ do--- ary <- rb_ary_new2 $ fromIntegral $ length l--- mapM_ (rb_ary_push ary . fromRVal) l--- return ary--- T_OBJECT v -> v--- -- T_CLASS v -> v--- T_BIGNUM b -> rb_str_to_inum (unsafePerformIO $ (newCAString $ show b) >>= rb_str_new2) 10 1--- _ -> error "sorry, haven't implemented that yet."------ fromVal :: Value -> RValue--- fromVal v = case target of--- RT_NIL -> T_NIL--- RT_FIXNUM -> T_FIXNUM $ fix2int v--- RT_STRING -> T_STRING v -- $ unsafePerformIO $ str2cstr >>= peekCString --- RT_FLOAT -> T_FLOAT $ num2dbl v--- RT_BIGNUM -> T_BIGNUM $ read $ unsafePerformIO (rb_big2str v 10 >>= str2cstr >>= peekCString)--- RT_TRUE -> T_TRUE--- RT_FALSE -> T_FALSE--- RT_HASH -> T_HASH v--- RT_ARRAY -> T_ARRAY $ map fromVal $ unsafePerformIO $ mapM (rb_ary_entry v . fromIntegral) [0..(rb_ary_len v) - 1]--- RT_OBJECT -> T_OBJECT v--- -- RT_CLASS -> T_CLASS v--- _ -> error ("didn't work: " ++ show target)--- where target :: RubyType--- target = toEnum $ rtype v
Language/Ruby/Hubris/GHCBuild.hs view
@@ -7,7 +7,7 @@ import Outputable import StringBuffer import System.Process-import Control.Monad(forM_)+import Control.Monad(forM_,guard) import System.IO(hPutStr, hClose, openTempFile) import System( exitWith, system) import System.Exit@@ -18,58 +18,23 @@ defaultGHCOptions = GHCOptions { strict = True } type Filename = String -genHaskellFile :: String -> IO String-genHaskellFile code = do (name, handle) <- openTempFile "/tmp" "hubris_XXXXX.hs"- hPutStr handle code- hClose handle- return name --- sh = showSDoc . ppr--- this one's a bit tricky: we _could_ use the GHC api, but i don't care too much.--- let's keep it simple.------ ok, new plan: handling it the filthy way is awful.------ We do need rshim.o, but it's packaged in the hubris lib, with any luck.+withFile :: String -> IO String+withFile code = do (name, handle) <- openTempFile "/tmp" "hubris_XXXXX.hs"+ hPutStr handle code+ hClose handle+ return name+ ghcBuild :: Filename -> String -> String -> [Filename] -> [Filename] -> [String]-> IO (Maybe (ExitCode,String)) ghcBuild libFile immediateSource modName extra_sources c_sources args =- do -- putStrLn ("modname is " ++ modName)- -- let c_wrapper = modName ++ ".aux.o"- -- eesh, this is awful...- -- doOrDie $ System.system("gcc -c -I/opt/local/include/ruby-1.9.1 -o " ++ c_wrapper ++ " " ++ unwords c_sources)- haskellSrcFile <- genHaskellFile immediateSource- noisySystem ghc $ ["--make", "-shared", "-dynamic", "-o", libFile, "-optl-Wl,-rpath," ++ libdir,+ do haskellSrcFile <- withFile immediateSource+ noisySystem ghc $ ["--make", "-shared", "-dynamic", "-o",libFile,"-fPIC", "-L" ++ libdir,"-optl-Wl,-rpath," ++ libdir, "-lHSrts-ghc" ++ Config.cProjectVersion, haskellSrcFile] ++ map ("-I"++) extraIncludeDirs ++ extra_sources ++ c_sources ++ args--- defaultErrorHandler defaultDynFlags $ do--- res <- runGhc (Just libdir) $ do--- dflags <- getSessionDynFlags --- (newflags, leftovers, warnings) <- GHC.parseDynamicFlags dflags --- $ map noLoc $ [ "-shared", "-o",libFile,"-optl-Wl,-rpath," ++ libdir, --- "-lHSrts-ghc" ++ Config.cProjectVersion]--- trace ("left2: " ++ sh leftovers) $ trace ("warns2: " ++ (sh warnings)) $ setSessionDynFlags newflags---- forM_ (haskellSrcFile:extra_sources) (\file -> guessTarget file Nothing >>= addTarget) ---- load LoadAllTargets--- -- doOrDie $ System.system("ld -dylib -flat_namespace -o " ++ libFile ++ " " ++ unwords ["foo"++ libFile, c_wrapper])--- print res--- return (case res of--- Succeeded -> True--- _ -> False)- noisySystem :: String -> [String] -> IO (Maybe (ExitCode, String))-noisySystem cmd args = - do putStrLn $ unwords (cmd:args)- (errCode, out, err) <- readProcessWithExitCode cmd args ""- return $ if (errCode == ExitSuccess)- then Nothing- else Just (errCode, unlines ["output: " ++ out, "error: " ++ err])---- doOrDie :: IO ExitCode -> IO ()--- doOrDie action = do res <- action--- case res of--- ExitSuccess -> return ()--- i -> exitWith i+noisySystem cmd args = do putStrLn $ unwords (cmd:args)+ (errCode, out, err) <- readProcessWithExitCode cmd args ""+ return $ guard (errCode /= ExitSuccess) >> + Just (errCode, unlines ["output: " ++ out, "error: " ++ err])
Language/Ruby/Hubris/LibraryBuilder.hs view
@@ -29,9 +29,10 @@ generateLib :: Filename -> [Filename] -> ModuleName -> [String] -> [String] -> IO (Either Filename String) generateLib libFile sources moduleName buildArgs packages = do -- set up the static args once - GHC.parseStaticFlags $ map noLoc $ words $ "-dynamic -fPIC" ++ unwords (map ("-package "++) ("hubris":packages)) +-- GHC.parseStaticFlags $ map noLoc $ words $ "-dynamic -fPIC" ++ unwords (map ("-package "++) ("hubris":packages)) + -- don't think i need dynamic or PIC - we're not generating machine code.+ GHC.parseStaticFlags $ map noLoc $ map ("-package "++) ("hubris":packages) - -- let libFile = zenc ("libHubris_" ++ moduleName)) s <- generateSource sources moduleName case s of Left s -> return $ Left ("HINT error: " ++ show s)@@ -41,8 +42,8 @@ putStrLn "C:" putStrLn c - bindings <- genCFile c -- should really delete afterwards.- res <- ghcBuild libFile mod ("Language.Ruby.Hubris.Exports." ++ moduleName) sources [bindings] buildArgs+ c_sources <- genCFile c -- should really delete afterwards.+ res <- ghcBuild libFile mod ("Language.Ruby.Hubris.Exports." ++ moduleName) sources [c_sources] buildArgs return (case res of Nothing -> Right libFile@@ -76,7 +77,7 @@ ,"#include <stdlib.h>" ,"#define HAVE_STRUCT_TIMESPEC 1" ,"#include <ruby.h>"--- ,"#define DEBUG 1"+ ,"#define DEBUG 1" ,"#ifdef DEBUG" ,"#define eprintf printf" ,"#else"@@ -114,6 +115,8 @@ wrapper f = let res = unlines ["VALUE " ++ f ++ "(VALUE mod, VALUE v){" ," eprintf(\""++f++" has been called\\n\");" ," VALUE res = hubrish_" ++ f ++"(v);"+ ," eprintf(\"hubrish "++f++" has been called\\n\");"+-- ," return res;" ," if (rb_obj_is_kind_of(res,rb_eException)) {" ," eprintf(\""++f++" has provoked an exception\\n\");" ," rb_exc_raise(res);"
Setup.hs view
@@ -3,16 +3,28 @@ import Distribution.Simple.Setup import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Utils-import Distribution.PackageDescription+import qualified Distribution.PackageDescription as D import Distribution.Verbosity import System.Directory-main = defaultMainWithHooks hooks+import System.Process+import Maybe+import qualified Distribution.ModuleName as Modname+main = do+ includeDir <- readProcess "ruby" ["-rrbconfig", "-e", "print RbConfig::CONFIG['archdir']"] ""+ defaultMainWithHooks (hooks includeDir) -hooks = simpleUserHooks+hooks includeDir = simpleUserHooks { preConf = \arg flags -> do -- probably a nicer way of getting that directory... createDirectoryIfMissing True "dist/build/autogen"- writeFile "dist/build/autogen/Includes.hs" ("module Includes where\nextraIncludeDirs=" ++ show (configExtraIncludeDirs flags))- return emptyHookedBuildInfo+ -- FILTHY HACK+ writeFile "dist/build/autogen/Includes.hs" ("module Includes where\nextraIncludeDirs=[\"" ++ includeDir++"\"]") -- show (configExtraIncludeDirs flags))+ return D.emptyHookedBuildInfo,+ confHook = \ info flags -> (confHook simpleUserHooks) info (flags { configSharedLib = Flag True, configExtraIncludeDirs = [includeDir] }),+ sDistHook = \ pkg lbi hooks flags -> let lib = fromJust $ D.library pkg+ modules = filter (/= Modname.fromString "Includes") $ D.exposedModules lib+ pkg' = pkg { D.library = Just $ lib { D.exposedModules = modules } } + in sDistHook simpleUserHooks pkg' lbi hooks flags + }
cbits/rshim.c view
@@ -13,15 +13,20 @@ return TYPE(obj); } -VALUE int2fix(int x) {- return INT2FIX(x);+VALUE int2fix(long x) {+ printf("long2fix called\n");+ return LONG2FIX(x); } -int fix2int(VALUE x) {- return FIX2INT(x);+long fix2int(VALUE x) {+ printf("fix2long called\n");+ // return rb_num2int(x);+ return FIX2LONG(x);+ // return FIX2INT(x); } double num2dbl(VALUE x) {+ printf("num2dbl called\n"); return NUM2DBL(x); }
cbits/rshim.h view
@@ -5,8 +5,8 @@ // did this really have to be a macro? BAD MATZ unsigned int rtype(VALUE obj);-VALUE int2fix(int i);-int fix2int(VALUE x);+VALUE int2fix(long i);+long fix2int(VALUE x); double num2dbl(VALUE x); unsigned int rb_ary_len(VALUE x); VALUE keys(VALUE hash);
hubris.cabal view
@@ -1,5 +1,5 @@ Name: hubris-Version: 0.0.2+Version: 0.0.3 Author: Mark Wotton Maintainer: mwotton@gmail.com Build-Type: Simple@@ -17,17 +17,13 @@ Description: Support library for Hubris, the Ruby to Haskell bridge more info at <http://github.com/mwotton/Hubris-Haskell> .- short version: ./Setup configure --enable-shared --ghc-options=-dynamic --extra-include-dirs=... --extra-lib-dirs=...- .- If you omit any of those flags, it will seem to work then blow up at runtime.- . Anyway, this version strips the boilerplate that used to be necessary, and is intended to be used in conjunction with <http://github.com/mwotton/Hubris>. Library--- the ordering is critical, because Cabal doesn't do dependency analysis.+ -- the ordering is critical, because Cabal doesn't do dependency analysis. Exposed-Modules: Language.Ruby.Hubris.Binding, Language.Ruby.Hubris, Language.Ruby.Hubris.LibraryBuilder, Language.Ruby.Hubris.ZCode, Language.Ruby.Hubris.GHCBuild, Includes c-sources: cbits/rshim.c- includes: cbits/rshim.h+ -- includes: cbits/rshim.h install-includes: cbits/rshim.h include-dirs: cbits -- a proper fix for this would involve autoconf and I'm not feeling up to it.@@ -43,9 +39,4 @@ Other-Modules: Language.Ruby.Hubris.Binding c-sources: cbits/rshim.c include-dirs: cbits - extra-libraries: ruby- -- This is bad form, apparently, and if i include it, ./Setup dist cries big fat tears,- -- but you _really_ want a dynamic lib with Hubrify, or you'll get a truly- -- huge binary (may not even link, I had problems with the iconv dependency from HSbase)- -- anyway, pass "--ghc-options=-dynamic" to ./Setup configure, and you should be apples.- -- ghc-options: -dynamic+ extra-libraries: ruby1.8