diff --git a/Hubrify.hs b/Hubrify.hs --- a/Hubrify.hs +++ b/Hubrify.hs @@ -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 diff --git a/Includes.hs b/Includes.hs new file mode 100644 --- /dev/null +++ b/Includes.hs @@ -0,0 +1,2 @@ +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,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 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 @@ -19,7 +19,7 @@ #include "rshim.h" #include --- 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" + + + 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 @@ -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 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 @@ -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 " + ,"#include " + ,"#define HAVE_STRUCT_TIMESPEC 1" + ,"#include " +-- ,"#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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 + } diff --git a/cbits/rshim.c b/cbits/rshim.c --- a/cbits/rshim.c +++ b/cbits/rshim.c @@ -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)); +} + diff --git a/cbits/rshim.h b/cbits/rshim.h --- a/cbits/rshim.h +++ b/cbits/rshim.h @@ -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, diff --git a/hubris.cabal b/hubris.cabal --- a/hubris.cabal +++ b/hubris.cabal @@ -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 Maintainer: Mark Wotton -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 + . + 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. - 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