diff --git a/Hubrify.hs b/Hubrify.hs --- a/Hubrify.hs +++ b/Hubrify.hs @@ -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 diff --git a/Includes.hs b/Includes.hs deleted file mode 100644 --- a/Includes.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Includes where -extraIncludeDirs=["/opt/local/include/ruby-1.9.1"] diff --git a/Language/Ruby/Hubris.hs b/Language/Ruby/Hubris.hs --- a/Language/Ruby/Hubris.hs +++ b/Language/Ruby/Hubris.hs @@ -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 - diff --git a/Language/Ruby/Hubris/Binding.chs b/Language/Ruby/Hubris/Binding.chs --- a/Language/Ruby/Hubris/Binding.chs +++ b/Language/Ruby/Hubris/Binding.chs @@ -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 diff --git a/Language/Ruby/Hubris/GHCBuild.hs b/Language/Ruby/Hubris/GHCBuild.hs --- a/Language/Ruby/Hubris/GHCBuild.hs +++ b/Language/Ruby/Hubris/GHCBuild.hs @@ -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]) diff --git a/Language/Ruby/Hubris/LibraryBuilder.hs b/Language/Ruby/Hubris/LibraryBuilder.hs --- a/Language/Ruby/Hubris/LibraryBuilder.hs +++ b/Language/Ruby/Hubris/LibraryBuilder.hs @@ -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 " ,"#define HAVE_STRUCT_TIMESPEC 1" ,"#include " --- ,"#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);" diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 + } diff --git a/cbits/rshim.c b/cbits/rshim.c --- a/cbits/rshim.c +++ b/cbits/rshim.c @@ -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); } diff --git a/cbits/rshim.h b/cbits/rshim.h --- a/cbits/rshim.h +++ b/cbits/rshim.h @@ -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); diff --git a/hubris.cabal b/hubris.cabal --- a/hubris.cabal +++ b/hubris.cabal @@ -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 . - 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 . 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