hubris 0.0.1 → 0.0.2
raw patch · 10 files changed
+496/−203 lines, 10 filesdep +processdep −haskell-src-metadep ~Cabalsetup-changed
Dependencies added: process
Dependencies removed: haskell-src-meta
Dependency ranges changed: Cabal
Files
- Hubrify.hs +66/−2
- Includes.hs +2/−0
- Language/Ruby/Hubris.hs +131/−37
- Language/Ruby/Hubris/Binding.chs +101/−81
- Language/Ruby/Hubris/GHCBuild.hs +52/−28
- Language/Ruby/Hubris/LibraryBuilder.hs +97/−38
- Setup.hs +17/−1
- cbits/rshim.c +8/−0
- cbits/rshim.h +1/−0
- hubris.cabal +21/−16
Hubrify.hs view
@@ -1,7 +1,71 @@ module Main where import Language.Ruby.Hubris.LibraryBuilder import System+import System.Exit+import Control.Monad(when)+import Language.Ruby.Hubris.ZCode (zenc,zdec) +import System.Console.GetOpt+import Data.Maybe ( fromMaybe )++++data Options = Options+ { optVerbose :: Bool+ , optStrict :: Bool+ , optShowVersion :: Bool+ , optOutput :: FilePath+ , optModule :: String+ , optInput :: Maybe FilePath+ , optPackages :: [String]+ } deriving Show++defaultOptions = Options+ { optVerbose = False+ , optShowVersion = False+ , optStrict = False+ , optInput = Nothing+ , optPackages = []+ }++options :: [OptDescr (Options -> Options)]+options =+ [ Option ['v'] ["verbose"]+ (NoArg (\ opts -> opts { optVerbose = True }))+ "chatty output on stderr"+ , Option [] ["strict"]+ (NoArg (\ opts -> opts { optStrict = True }))+ "bondage and discipline mode"+ , Option ['o'] ["output"]+ (ReqArg ((\ f opts -> opts { optOutput = f })) "libFile")+ "output FILE"+ , 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")+ "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))+ where header = "Usage: Hubrify --module MODULE --output LIBFILE (--packages PACKAGE1 ...) sourceFiles ..."+ main = do- (mod:extra_src) <- getArgs- generateLib extra_src mod >>= print+ (o,srcs) <- getArgs >>= hubrisOpts+ -- HACK this may be the worst thing ever+ + let ghcArgs = if optStrict o+ then ["-Wall", "-Werror","-fno-warn-unused-imports"]+ else []+ -- putStrLn $ show $ optPackages o+ res <- generateLib (optOutput o) srcs (optModule o) ghcArgs (optPackages o)+ -- when (optVerbose o) (putStr $unlines msgs)+ + -- print res+ case res of+ Left a -> putStrLn ("Failed: " ++ a) >> exitFailure+ Right _ -> exitSuccess
+ Includes.hs view
@@ -0,0 +1,2 @@+module Includes where+extraIncludeDirs=["/opt/local/include/ruby-1.9.1"]
Language/Ruby/Hubris.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-} module Language.Ruby.Hubris where import Data.Word@@ -8,64 +8,164 @@ import Foreign.C.Types import Language.Ruby.Hubris.Binding import Control.Monad (forM)+import Control.Applicative+import Debug.Trace+import Foreign.C.String+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Internal(w2c,c2w) -- type Value = CULong+import System.IO.Unsafe+import Data.Array.IArray+import Data.Maybe+import Control.Exception+import Prelude hiding(catch)+import Monad hiding (when)+import Data.Typeable +wrap :: (Haskellable a, Show b, 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"+ Right a -> return a +data HubrisException = HubrisException+ deriving(Show, Typeable) -wrap :: (Haskellable a, Rubyable b) => (a->b) -> (Value -> Value)-wrap func ar = fromRVal $ case (toHaskell $ fromVal ar) of- Just a -> toRuby $ func a- Nothing -> T_NIL+instance Exception HubrisException --- fromVal :: Value -> RValue--- fromRVal ::RValue -> Value--- fromVal = undefined--- fromRVal = undefined+-- utility stuff:+sshow s = Prelude.map w2c $S.unpack s+lshow s = Prelude.map w2c $L.unpack s+--traces = flip trace+traces a b = a +when v b c = if (rubyType v == b)+ then c+ else throw HubrisException+ class Haskellable a where- toHaskell :: RValue -> Maybe a+ toHaskell :: Value -> a class Rubyable a where- toRuby :: a -> RValue+ toRuby :: a -> Value instance Haskellable Int where- toHaskell (T_FIXNUM i) = Just i- toHaskell _ = Nothing+ toHaskell v = when v RT_FIXNUM $ fix2int v + instance Rubyable Int where- toRuby i = T_FIXNUM i+ toRuby i = int2fix i instance Haskellable Integer where- toHaskell (T_BIGNUM i) = Just i- toHaskell _ = Nothing+ toHaskell v = case rubyType v of+ RT_BIGNUM -> read $ unsafePerformIO (rb_big2str v 10 >>= str2cstr >>= peekCString)+ RT_FIXNUM -> fromIntegral $ fix2int v+ _ -> throw HubrisException -- wonder if it's kosher to just let the pattern match fail... instance Rubyable Integer where- toRuby i = T_BIGNUM i+ toRuby i = rb_str_to_inum (unsafePerformIO $ (newCAString $ show i) >>= rb_str_new2) 10 1 instance Haskellable Bool where- toHaskell T_TRUE = Just True- toHaskell T_FALSE = Just False- toHaskell _ = Nothing+ toHaskell v = case rubyType v of+ RT_TRUE -> True+ RT_FALSE -> False+ _ -> throw HubrisException instance Rubyable Bool where- toRuby True = T_TRUE- toRuby False = T_FALSE+ toRuby True = constToRuby RUBY_Qtrue+ toRuby False = constToRuby RUBY_Qfalse instance Rubyable Double where- toRuby d = T_FLOAT d+ toRuby d = rb_float_new d instance Haskellable Double where- toHaskell (T_FLOAT f) = Just f- toHaskell (T_FIXNUM i) = Just $ fromIntegral i -- does this make sense?- toHaskell _ = Nothing + toHaskell v = case rubyType v of+ RT_FLOAT -> num2dbl v+ RT_FIXNUM -> fromIntegral $ fix2int v+ _ -> throw HubrisException -instance Haskellable String where- toHaskell (T_STRING s) = Just s- toHaskell _ = Nothing-instance Rubyable String where- toRuby s = (T_STRING s)+instance Rubyable Value where+ toRuby v = v +instance Haskellable Value where+ toHaskell v = v ++instance Haskellable S.ByteString where+ toHaskell v = when v RT_STRING $ unsafePerformIO $ + do a <- str2cstr v >>= S.packCString + return a `traces` ("strict to Haskell: " ++ sshow a)++instance Rubyable S.ByteString where+ toRuby s = unsafePerformIO $ S.useAsCStringLen s $ + \(cs,len) -> rb_str_new (cs,len) `traces` ("sstrict back to ruby:" ++ (show $ S.unpack s))+ ++++instance Haskellable L.ByteString where+ toHaskell v = L.fromChunks [toHaskell v]++instance Rubyable L.ByteString where+ toRuby s = let res = S.concat $ L.toChunks s+ in trace ("lazy back to ruby: " ++ show (S.unpack res)) (toRuby res)++instance Haskellable a => Haskellable [a] where+ toHaskell v = when v RT_ARRAY $ Prelude.map toHaskell $ unsafePerformIO $ mapM (rb_ary_entry v . fromIntegral) [0..(rb_ary_len v) - 1]++++instance Rubyable a => Rubyable [a] where+ toRuby l = unsafePerformIO $ do ary <- rb_ary_new2 $ fromIntegral $ Prelude.length l+ mapM_ (\x -> rb_ary_push ary (toRuby x)) l+ return ary++-- this one is probably horribly inefficient.+instance (Integral a, Ix a, Haskellable b) => Haskellable (Array a b) where+ toHaskell v = let x = toHaskell v in (listArray (0, fromIntegral $ Prelude.length x) x)++-- could be more efficient, perhaps, but it's space-efficient still thanks to laziness+instance (Rubyable b, Ix a) => Rubyable (Array a b) where+ toRuby a = toRuby $ Data.Array.IArray.elems a++instance Haskellable RubyHash where+ toHaskell v = when v RT_HASH $ RubyHash v++instance Rubyable RubyHash where+ toRuby (RubyHash v) = v+++-- Nil maps to Nothing - all the other falsey values map to real haskell values.+instance Haskellable a => Haskellable (Maybe a) where + toHaskell v = case rubyType v of+ RT_NIL -> Nothing `traces` "Haskell got nothing"+ _ -> Just (toHaskell v) `traces` "Haskell got a value"+ +instance Rubyable a => Rubyable (Maybe a) where+ toRuby Nothing = constToRuby RUBY_Qnil `traces` "Sending ruby a nil"+ toRuby (Just a) = toRuby a `traces` "Sending a value back"++newtype RubyHash = RubyHash Value -- don't export constructor++instance (Ord a, Eq a, Rubyable a, Rubyable b) => Rubyable (Map.Map a b) where+ toRuby s = unsafePerformIO $ + do hash <- rb_hash_new+ mapM_ (\(k,v) -> rb_hash_aset hash (toRuby k) (toRuby v)) (toList s)+ return hash++instance (Ord a, Eq a, Haskellable b, Haskellable a) => Haskellable (Map.Map a b) where+ toHaskell hash = when hash RT_HASH $ unsafePerformIO $ + -- fromJust is legit, rb_keys will always return list+ do l :: [Value] <- toHaskell <$> rb_keys hash+ foldM (\m k -> do val <- rb_hash_aref hash k+ return $ Map.insert (toHaskell k) + (toHaskell val)+ m)+ Map.empty l+ ++ -- This is a tricky case. -- The ruby FFI wants us to pass a C callback which it can apply to each key-value pair -- of the hash, so Haskell cannot be fully in control of the process - this makes building@@ -96,9 +196,3 @@ -- toHaskell _ = Nothing -instance (Rubyable a, Rubyable b) => Rubyable (Map.Map a b) where- toRuby s = unsafePerformIO $ - do hash <- rb_hash_new- forM (toList s)- (\(k,v) -> rb_hash_aset hash (fromRVal $ toRuby k) (fromRVal $ toRuby v))- return $ T_HASH hash
Language/Ruby/Hubris/Binding.chs view
@@ -19,7 +19,7 @@ #include "rshim.h" #include <ruby.h> --- import Control.Applicative+import Control.Applicative -- import Control.Monad import Data.Word -- import Foreign.Ptr@@ -33,13 +33,19 @@ {# context lib="rshim" #} {# enum RubyType {} deriving (Eq, Show) #} -- maybe Ord?+rubyType :: Value -> RubyType+rubyType = toEnum . rtype++constToRuby :: RubyConst -> Value+constToRuby = fromIntegral . fromEnum + #if RUBY_VERSION_CODE <= 187-data RubyConsts = RUBY_Qfalse +data RubyConst = RUBY_Qfalse | RUBY_Qtrue | RUBY_Qnil | RUBY_Qundef -instance Enum RubyConsts where+instance Enum RubyConst where fromEnum RUBY_Qfalse = 0 fromEnum RUBY_Qtrue = 2 fromEnum RUBY_Qnil = 4@@ -50,107 +56,121 @@ toEnum 4 = RUBY_Qnil toEnum 6 = RUBY_Qundef #else-{# enum ruby_special_consts as RubyConsts {} deriving (Eq,Show) #}+{# enum ruby_special_consts as RubyConst {} deriving (Eq,Show) #} #endif++str2cstr str = rb_str2cstr str 0 type Value = CULong -- FIXME, we'd prefer to import the type VALUE directly-foreign import ccall unsafe "ruby.h rb_str2cstr" rb_str2cstr :: Value -> CInt -> CString-foreign import ccall unsafe "ruby.h rb_str_new2" rb_str_new2 :: CString -> Value-foreign import ccall unsafe "ruby.h rb_ary_new2" rb_ary_new2 :: CLong -> IO Value-foreign import ccall unsafe "ruby.h rb_ary_push" rb_ary_push :: Value -> Value -> IO ()-foreign import ccall unsafe "ruby.h rb_float_new" rb_float_new :: Double -> Value-foreign import ccall unsafe "ruby.h rb_big2str" rb_big2str :: Value -> Int -> Value-foreign import ccall unsafe "ruby.h rb_str_to_inum" rb_str_to_inum :: Value -> Int -> Int -> Value-foreign import ccall unsafe "ruby.h ruby_init" ruby_init :: IO ()+foreign import ccall safe "ruby.h rb_str2cstr" rb_str2cstr :: Value -> CInt -> IO CString+foreign import ccall safe "ruby.h rb_str_new2" rb_str_new2 :: CString -> IO Value+foreign import ccall safe "ruby.h rb_str_new2" rb_str_new_ :: CString -> Int -> IO Value +foreign import ccall safe "ruby.h rb_ary_new2" rb_ary_new2 :: CLong -> IO Value+foreign import ccall safe "ruby.h rb_ary_push" rb_ary_push :: Value -> Value -> IO ()+foreign import ccall safe "ruby.h rb_float_new" rb_float_new :: Double -> Value+foreign import ccall safe "ruby.h rb_big2str" rb_big2str :: Value -> Int -> IO Value+foreign import ccall safe "ruby.h rb_str_to_inum" rb_str_to_inum :: Value -> Int -> Int -> Value+-- foreign import ccall safe "ruby.h ruby_init" ruby_init :: IO () +rb_str_new = uncurry rb_str_new_+ -- we're being a bit filthy here - the interface is all macros, so we're digging in to find what it actually is-foreign import ccall unsafe "rshim.h rb_ary_len" rb_ary_len :: Value -> CUInt-foreign import ccall unsafe "rshim.h rtype" rtype :: Value -> Int-foreign import ccall unsafe "rshim.h int2fix" int2fix :: Int -> Value-foreign import ccall unsafe "rshim.h fix2int" fix2int :: Value -> Int-foreign import ccall unsafe "rshim.h num2dbl" num2dbl :: Value -> Double -- technically CDoubles, but jhc promises they're the same-foreign import ccall unsafe "rshim.h keys" rb_keys :: Value -> IO Value+foreign import ccall safe "rshim.h rb_ary_len" rb_ary_len :: Value -> CUInt+foreign import ccall safe "rshim.h rtype" rtype :: Value -> Int +foreign import ccall safe "rshim.h int2fix" int2fix :: Int -> Value+foreign import ccall safe "rshim.h fix2int" fix2int :: Value -> Int+foreign import ccall safe "rshim.h num2dbl" num2dbl :: Value -> Double -- technically CDoubles, but jhc promises they're the same+foreign import ccall safe "rshim.h keys" rb_keys :: Value -> IO Value+foreign import ccall safe "rshim.h buildException" buildException :: CString -> IO Value+-- foreign import ccall safe "ruby.h rb_funcall" rb_funcall :: Value -> ID ->+ -- this line crashes jhc-foreign import ccall unsafe "intern.h rb_ary_entry" rb_ary_entry :: Value -> CLong -> IO Value+foreign import ccall safe "intern.h rb_ary_entry" rb_ary_entry :: Value -> CLong -> IO Value foreign import ccall safe "ruby.h rb_raise" rb_raise :: Value -> CString -> IO ()-foreign import ccall unsafe "ruby.h rb_eval_string" rb_eval_string :: CString -> Value+foreign import ccall safe "ruby.h rb_eval_string" rb_eval_string :: CString -> IO Value -foreign import ccall unsafe "intern.h rb_hash_aset" rb_hash_aset :: Value -> Value -> Value -> IO ()-foreign import ccall unsafe "intern.h rb_hash_new" rb_hash_new :: IO Value-foreign import ccall unsafe "intern.h rb_hash_aref" rb_hash_aref :: Value -> Value -> IO Value+foreign import ccall safe "intern.h rb_hash_aset" rb_hash_aset :: Value -> Value -> Value -> IO ()+foreign import ccall safe "intern.h rb_hash_new" rb_hash_new :: IO Value+foreign import ccall safe "intern.h rb_hash_aref" rb_hash_aref :: Value -> Value -> IO Value +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 String - -- 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 +-- data RValue = T_NIL +-- | T_FLOAT Double+-- | T_STRING Value - | T_SYMBOL Word -- interned string- deriving (Eq, Show)+-- -- 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_OBJECT --- | T_CLASS ++ -- | 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 -> rb_str_new2 $ unsafePerformIO $ newCAString str- T_FIXNUM i -> int2fix i+-- -- 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 -> fromIntegral $ fromEnum RUBY_Qtrue- T_FALSE -> fromIntegral $ fromEnum RUBY_Qfalse- T_NIL -> fromIntegral $ fromEnum 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_BIGNUM b -> rb_str_to_inum (rb_str_new2 $ unsafePerformIO $ newCAString $ show b) 10 1- _ -> error "sorry, haven't implemented that yet."+-- -- 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 $ unsafePerformIO $ peekCString $ rb_str2cstr v 0- RT_FLOAT -> T_FLOAT $ num2dbl v- RT_BIGNUM -> T_BIGNUM $ read $ unsafePerformIO $ peekCString $ rb_str2cstr (rb_big2str v 10) 0- 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] - _ -> error "didn't work" -- (show target)- where target :: RubyType- target = toEnum $ rtype v +-- 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 -unsafeThrow :: String -> a-unsafeThrow s = unsafePerformIO $ throwException s >> undefined-throwException :: String -> IO Value-throwException s = do he <- newCAString "HaskellError"- err <- newCAString s- rb_raise (rb_eval_string he) err- error "shouldn't ever get here"+++
Language/Ruby/Hubris/GHCBuild.hs view
@@ -6,46 +6,70 @@ import GHC.Paths import Outputable import StringBuffer-import System.Time+import System.Process import Control.Monad(forM_)+import System.IO(hPutStr, hClose, openTempFile)+import System( exitWith, system)+import System.Exit+import Includes (extraIncludeDirs) -- this is generated by Cabal + newtype GHCOptions = GHCOptions { strict :: Bool } 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+-- 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.-ghcBuild :: Filename -> String -> String -> [Filename] -> GHCOptions -> IO Bool-ghcBuild libFile immediateSource modName extra_sources options =- do srcBuffer <- stringToStringBuffer immediateSource- putStrLn ("modname is " ++ modName)- writeFile "/tmp/foo.hs" immediateSource- time <- getClockTime -- i suppose we've just made it now...- defaultErrorHandler defaultDynFlags $ do- res <- runGhc (Just libdir) $ do- dflags <- getSessionDynFlags+--+-- We do need rshim.o, but it's packaged in the hubris lib, with any luck.+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,+ "-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 $ (words $ "-shared -o " ++ libFile ++ " -optl-Wl,-rpath," ++ libdir - ++ " /Users/mwotton/projects/Hubris/lib/rshim.o -lHSrts-ghc" ++ Config.cProjectVersion)- trace ("left: " ++ sh leftovers) $ trace (sh warnings) $ setSessionDynFlags newflags- - forM_ ("/tmp/foo.hs":extra_sources) (\file -> guessTarget file Nothing >>= addTarget) +-- (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 - load LoadAllTargets- -- do something with c_sources and extra_sources--- setTargets [Target { targetContents = Just ( srcBuffer, time ), --- targetAllowObjCode = True,--- targetId = TargetModule $ mkModuleName modName--- } ]+-- forM_ (haskellSrcFile:extra_sources) (\file -> guessTarget file Nothing >>= addTarget) - -- } ]- - return (case res of- Succeeded -> True- _ -> False)+-- 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
Language/Ruby/Hubris/LibraryBuilder.hs view
@@ -3,74 +3,133 @@ import Language.Ruby.Hubris.ZCode (zenc, zdec) import Language.Ruby.Hubris import Language.Haskell.Interpreter-import Language.Haskell.Meta.QQ.HsHere+-- import Language.Haskell.Meta.QQ.HsHere import Language.Ruby.Hubris.GHCBuild -import Debug.Trace+import List(intersperse)+import qualified Debug.Trace import Control.Monad import Control.Monad.Error.Class import GHC(parseStaticFlags, noLoc)+import System.IO(hPutStr, hClose, openTempFile)+import System.Exit+import Language.Ruby.Hubris.ZCode (zenc,zdec)+ type Filename = String+trace a b = b -generateLib :: [Filename] -> ModuleName -> IO (Maybe Filename)-generateLib sources moduleName = do- -- set up the static args once- GHC.parseStaticFlags $ map noLoc $ words "-dynamic -fPIC -package hubris"+-- argh, this is ugly. should be a withTempFile construct of some kind.+genCFile :: String -> IO String+genCFile code = do (name, handle) <- openTempFile "/tmp" "hubris_interface_XXXXX.c"+ hPutStr handle code+ hClose handle+ return name - let libFile = zenc ("libHubris_" ++ moduleName)+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)) ++ -- let libFile = zenc ("libHubris_" ++ moduleName)) s <- generateSource sources moduleName case s of- Left s -> putStrLn ("HINT error: " ++ show s) >> return Nothing- Right mod -> do+ Left s -> return $ Left ("HINT error: " ++ show s)+ Right Nothing -> return $ Left("no functions found!")+ Right (Just (c,mod)) -> do putStrLn mod- res <- ghcBuild libFile mod ("Language.Ruby.Hubris.Exports." ++ moduleName) sources defaultGHCOptions + putStrLn "C:"+ putStrLn c++ bindings <- genCFile c -- should really delete afterwards.+ res <- ghcBuild libFile mod ("Language.Ruby.Hubris.Exports." ++ moduleName) sources [bindings] buildArgs - return (if res - then Just libFile- else Nothing)+ return (case res of+ Nothing -> Right libFile+ Just (code,str) -> Left $ "code: " ++ show code ++"\nerr:" ++ str) generateSource :: [Filename] -> -- optional haskell source to load into the interpreter ModuleName -> -- name of the module to build a wrapper for- IO (Either InterpreterError String)+ IO (Either InterpreterError (Maybe (String,String))) generateSource sources moduleName = runInterpreter $ do- say $ show sources+ let zmoduleName = zenc moduleName loadModules sources- say "loaded"- -- setTopLevelModules [moduleName] setImportsQ $ map (\x->(x,Just x)) $ ("Language.Ruby.Hubris"):("Language.Ruby.Hubris.Binding"):moduleName:[]-- functions <- getFunctions moduleName say $ "Candidates: " ++ (show functions) -- ok, let's see if we can come up with an expression of the right type - exportable <- filterM (\func -> do let rubyVal ="(fromIntegral $ fromEnum $ Language.Ruby.Hubris.Binding.RUBY_Qtrue)"- let f = "Language.Ruby.Hubris.wrap " ++ moduleName ++"." ++func ++" " ++ rubyVal- say f- (typeOf f >>= \n -> say $ "type of wrap." ++ func ++ " is " ++ show n) - `catchError` (say . show)- typeChecks (f ++ "==" ++ rubyVal )) functions+ exportable <- filterM (\func -> do let rubyVal ="(fromIntegral $ fromEnum $ Language.Ruby.Hubris.Binding.RUBY_Qtrue)"+ let f = "Language.Ruby.Hubris.wrap " ++ moduleName ++"." ++func ++" " ++ rubyVal+ say f+ (typeOf f >>= \n -> say $ "type of wrap." ++ func ++ " is " ++ show n) + `catchError` (say . show)+ typeChecks (f ++ "==" ++ rubyVal )) functions say $ "Exportable: " ++ (show exportable)- -- withTypes <- mapM (\x -> typeOf x >>= \t -> return (x,t)) exportable- return $ unlines $- -- ideally, all this stuff would be using something like the Interpolator module,- -- but haskell-src-meta is not going on 6.12 yet, so let's do it traditionally instead.+ return $ guard (not $ null exportable) >> return (genC exportable zmoduleName ,genHaskell exportable moduleName ) + +genC :: [String] -> String -> String+genC exportable zmoduleName= unlines $ + ["#include <stdio.h>"+ ,"#include <stdlib.h>"+ ,"#define HAVE_STRUCT_TIMESPEC 1"+ ,"#include <ruby.h>"+-- ,"#define DEBUG 1"+ ,"#ifdef DEBUG"+ ,"#define eprintf printf"+ ,"#else"+ ,"int eprintf(const char *f, ...){}"+ ,"#endif"+ ] +++ map forwardDecl exportable +++ map wrapper exportable +++ ["extern void safe_hs_init();"+ ,"extern VALUE Exports;"+ ,"void Init_" ++ zmoduleName ++ "(){"+ ," eprintf(\"loading\\n\");"+ ," VALUE Fake = Qnil;"+ ," safe_hs_init();"+ ," Fake = rb_define_module_under(Exports, \"" ++ zmoduleName ++ "\");"+ ," eprintf(\"defined module " ++ rubyName ++ ":%p\\n\", Fake);"+ ] ++ map def exportable ++ ["}"]+ where rubyName = "Hubris::Exports::" ++ zmoduleName - ["{-# LANGUAGE ForeignFunctionInterface #-}", - "module Language.Ruby.Hubris.Exports." ++ moduleName ++ " where",- "import Language.Ruby.Hubris",- "import qualified Prelude",- "import Language.Ruby.Hubris.Binding",- "import qualified " ++ moduleName] ++- [fun ++ " :: Value -> Value" | fun <- exportable ] ++- [fun ++ " = Language.Ruby.Hubris.wrap " ++ moduleName ++ "." ++ fun | fun <- exportable ] +++genHaskell exportable moduleName = unlines $ + ["{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}", + "module Language.Ruby.Hubris.Exports." ++ moduleName ++ " where",+ "import Language.Ruby.Hubris",+ "import qualified Prelude as P()",+ "import Language.Ruby.Hubris.Binding",+ "import qualified " ++ moduleName] +++ [fun ++ " :: Value -> Value" | fun <- exportable ] ++ - ["foreign export ccall \"" ++ fun ++ "\" " ++ fun ++ " :: Value -> Value" | fun <- exportable ]+ [fun ++ " b = (Language.Ruby.Hubris.wrap " ++ moduleName ++ "." ++ fun ++ ") b"| fun <- exportable ] ++ + ["foreign export ccall \"hubrish_" ++ fun ++ "\" " ++ fun ++ " :: Value -> Value" | fun <- exportable ] say = liftIO . putStrLn++wrapper :: String -> String+wrapper f = let res = unlines ["VALUE " ++ f ++ "(VALUE mod, VALUE v){"+ ," eprintf(\""++f++" has been called\\n\");"+ ," VALUE res = hubrish_" ++ f ++"(v);"+ ," if (rb_obj_is_kind_of(res,rb_eException)) {"+ ," eprintf(\""++f++" has provoked an exception\\n\");" + ," rb_exc_raise(res);"+ ," } else {"+ ," eprintf(\"returning from "++f++"\\n\");"+ ," return res;"+ ," }"+ ,"}"]+ in res + ++def :: String -> String+def f = " eprintf(\"Defining |" ++ f ++ "|\\n\");\n" ++ "rb_define_method(Fake, \"" ++ f ++"\","++ f++", 1);"++forwardDecl::String->String+forwardDecl f = "VALUE hubrish_" ++ f ++ "(VALUE);" getFunctions moduleName = do exports <- getModuleExports moduleName
Setup.hs view
@@ -1,2 +1,18 @@+{-# LANGUAGE NamedFieldPuns #-} import Distribution.Simple-main = defaultMain+import Distribution.Simple.Setup+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Utils+import Distribution.PackageDescription+import Distribution.Verbosity+import System.Directory+main = defaultMainWithHooks hooks++hooks = 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+ }
cbits/rshim.c view
@@ -32,3 +32,11 @@ VALUE keys(VALUE hash) { rb_funcall(hash, rb_intern("keys"), 0); }++VALUE buildException(char * message) {+ VALUE errclass = rb_eval_string("HaskellError");+ VALUE errobj = rb_exc_new2(errclass, message);+ return errobj;+ // return rb_funcall(errclass, rb_intern("new"), 1, rb_str_new2(message)); +}+
cbits/rshim.h view
@@ -10,6 +10,7 @@ double num2dbl(VALUE x); unsigned int rb_ary_len(VALUE x); VALUE keys(VALUE hash);+VALUE buildException(char *); // argh, and again enum RubyType { RT_NONE = T_NONE,
hubris.cabal view
@@ -1,5 +1,5 @@ Name: hubris-Version: 0.0.1+Version: 0.0.2 Author: Mark Wotton Maintainer: mwotton@gmail.com Build-Type: Simple@@ -9,38 +9,43 @@ Build-Type: Simple Author: Mark Wotton <mwotton@gmail.com> Maintainer: Mark Wotton <mwotton@gmail.com>-bug-reports: mailto:mwotton@gmail.com+bug-reports: http://github.com/mwotton/Hubris-Haskell/issues Category: Language Stability: Experimental extra-source-files: Synopsis: Support library for Hubris, the Ruby <=> Haskell bridge-Description: Support library for Hubris, the Ruby <=> Haskell bridge+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.- Exposed-Modules: Language.Ruby.Hubris.Binding, Language.Ruby.Hubris, Language.Ruby.Hubris.LibraryBuilder, Language.Ruby.Hubris.ZCode, Language.Ruby.Hubris.GHCBuild--- so this is a really filthy hack.- c-sources: cbits/rshim.c + 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 install-includes: cbits/rshim.h---- a proper fix for this would involve autoconf and I'm not feeling up to it.- include-dirs: cbits /opt/local/include/ruby-1.9.1/ - extra-lib-dirs: /opt/local/lib- -- c2hsoptions: --cpp=gcc --cppopts=-E --cppopts=-xc+ include-dirs: cbits+ -- a proper fix for this would involve autoconf and I'm not feeling up to it.+ -- best to pass the args on the command line.+ --extra-include-dirs=/opt/local/include/ruby-1.9.1/ + --extra-lib-dirs: /opt/local/lib extra-libraries: ruby- build-depends: ghc, Cabal>=1.7.4 && < 1.8, base, haskell98, containers, bytestring, array, mtl, old-time, ghc-paths, haskell-src-meta, hint+ build-depends: ghc, Cabal>=1.7.4 && < 1.9, base, haskell98, containers, bytestring, array, mtl, old-time, ghc-paths, hint Executable Hubrify Main-is: Hubrify.hs- Build-Depends: base >= 3 && < 5, ghc, Cabal>=1.7.4 && < 1.8, base, haskell98, containers, bytestring, array, mtl, old-time, ghc-paths, haskell-src-meta, hint+ Build-Depends: base >= 3 && < 5, ghc, Cabal>=1.7.4 && < 1.9, base, haskell98, containers, bytestring, array, mtl, old-time, ghc-paths, hint, process Other-Modules: Language.Ruby.Hubris.Binding c-sources: cbits/rshim.c - include-dirs: cbits /opt/local/include/ruby-1.9.1/ - extra-lib-dirs: /opt/local/lib+ 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 build, and you should be apples.+ -- anyway, pass "--ghc-options=-dynamic" to ./Setup configure, and you should be apples. -- ghc-options: -dynamic