From d8708fd3afadbb78a0d9583889fe0ac2bc4e0522 Mon Sep 17 00:00:00 2001 From: Mark Date: Sun, 29 Nov 2009 12:46:50 +1100 Subject: [PATCH] use exceptions for failed pattern-match --- Language/Ruby/Hubris.hs | 116 +++++++++++++++++-------- Language/Ruby/Hubris/Binding.chs | 4 + Language/Ruby/Hubris/LibraryBuilder.hs | 21 +++-- 3 files changed, 95 insertions(+), 46 deletions(-) diff --git a/Language/Ruby/Hubris.hs b/Language/Ruby/Hubris.hs index 6722d30..839a2ab 100644 --- 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,38 +8,44 @@ import System.IO.Unsafe (unsafePerformIO) import Foreign.C.Types import Language.Ruby.Hubris.Binding import Control.Monad (forM) +import Control.Applicative import Debug.Trace import Foreign.C.String -import Data.ByteString +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 ar = case (toHaskell ar) of - Just a -> toRuby $ func a - Nothing -> unsafePerformIO $ createException "BLAh" +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 --- wrapshow :: (Haskellable a, Show b, Show a, Rubyable b) => (a->b) -> (Value -> Value) --- wrapshow func ar = trace "Wrap called" $ let rv = fromVal ar --- in trace (unlines ["raw:" ++ show ar, --- "in:" ++ show rv]) $ fromRVal $ --- case (toHaskell rv) of --- Just a -> let v = func a in --- trace("out" ++ show v) (toRuby v) --- Nothing -> T_NIL +data HubrisException = HubrisException + deriving(Show, Typeable) +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 = guard (rubyType v == b) >> return c +when v b c = if (rubyType v == b) + then c + else throw HubrisException class Haskellable a where - toHaskell :: Value -> Maybe a + toHaskell :: Value -> a class Rubyable a where toRuby :: a -> Value @@ -53,18 +59,18 @@ instance Rubyable Int where instance Haskellable Integer where toHaskell v = case rubyType v of - RT_BIGNUM -> Just $ read $ unsafePerformIO (rb_big2str v 10 >>= str2cstr >>= peekCString) - RT_FIXNUM -> Just $ fromIntegral $ fix2int v - _ -> Nothing + 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 = rb_str_to_inum (unsafePerformIO $ (newCAString $ show i) >>= rb_str_new2) 10 1 instance Haskellable Bool where toHaskell v = case rubyType v of - RT_TRUE -> Just True - RT_FALSE -> Just False - _ -> Nothing + RT_TRUE -> True + RT_FALSE -> False + _ -> throw HubrisException instance Rubyable Bool where toRuby True = constToRuby RUBY_Qtrue @@ -75,24 +81,38 @@ instance Rubyable Double where instance Haskellable Double where toHaskell v = case rubyType v of - RT_FLOAT -> Just $ num2dbl v - RT_FIXNUM -> Just $ fromIntegral $ fix2int v - _ -> Nothing + RT_FLOAT -> num2dbl v + RT_FIXNUM -> fromIntegral $ fix2int v + _ -> throw HubrisException instance Rubyable Value where toRuby v = v instance Haskellable Value where - toHaskell v = Just v + toHaskell v = v -instance Haskellable ByteString where - toHaskell v = when v RT_STRING $ unsafePerformIO $ str2cstr v >>= packCString -instance Rubyable ByteString where - toRuby s = unsafePerformIO $ useAsCString s rb_str_new2 +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 Haskellable [Value] where - toHaskell v = when v RT_ARRAY $ unsafePerformIO $ mapM (rb_ary_entry v . fromIntegral) [0..(rb_ary_len v) - 1] +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] @@ -102,8 +122,8 @@ instance Rubyable a => Rubyable [a] where return ary -- this one is probably horribly inefficient. -instance (Integral a, Ix a) => Haskellable (Array a Value) where - toHaskell v = toHaskell v >>= \x -> return (listArray (0, fromIntegral $ Prelude.length x) x) +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 @@ -115,6 +135,17 @@ instance Haskellable RubyHash where 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 @@ -123,6 +154,17 @@ instance (Ord a, Eq a, Rubyable a, Rubyable b) => Rubyable (Map.Map a b) where 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 diff --git a/Language/Ruby/Hubris/Binding.chs b/Language/Ruby/Hubris/Binding.chs index cde674f..32dd530 100644 --- a/Language/Ruby/Hubris/Binding.chs +++ b/Language/Ruby/Hubris/Binding.chs @@ -63,6 +63,7 @@ str2cstr str = rb_str2cstr str 0 type Value = CULong -- FIXME, we'd prefer to import the type VALUE directly 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 @@ -70,6 +71,8 @@ foreign import ccall safe "ruby.h rb_big2str" rb_big2str :: Value -> Int 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 safe "rshim.h rb_ary_len" rb_ary_len :: Value -> CUInt foreign import ccall safe "rshim.h rtype" rtype :: Value -> Int @@ -79,6 +82,7 @@ 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 safe "intern.h rb_ary_entry" rb_ary_entry :: Value -> CLong -> IO Value diff --git a/Language/Ruby/Hubris/LibraryBuilder.hs b/Language/Ruby/Hubris/LibraryBuilder.hs index c742bed..d8775f0 100644 --- a/Language/Ruby/Hubris/LibraryBuilder.hs +++ b/Language/Ruby/Hubris/LibraryBuilder.hs @@ -7,7 +7,7 @@ import Language.Haskell.Meta.QQ.HsHere import Language.Ruby.Hubris.GHCBuild import List(intersperse) -import Debug.Trace +import qualified Debug.Trace import Control.Monad import Control.Monad.Error.Class @@ -17,7 +17,7 @@ import System.Exit import Language.Ruby.Hubris.ZCode (zenc,zdec) type Filename = String - +trace a b = b -- argh, this is ugly. should be a withTempFile construct of some kind. genCFile :: String -> IO String @@ -26,10 +26,10 @@ genCFile code = do (name, handle) <- openTempFile "/tmp" "hubris_interface_XXXXX hClose handle return name -generateLib :: Filename -> [Filename] -> ModuleName -> [String] -> IO (Either Filename String) -generateLib libFile sources moduleName buildArgs = do - -- set up the static args once - GHC.parseStaticFlags $ map noLoc $ words "-dynamic -fPIC -package hubris -package pcre-light" -- urgh, this needs work +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 @@ -62,9 +62,9 @@ generateSource sources moduleName = runInterpreter $ do 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) + say f + (typeOf f >>= \n -> say $ "type of wrap." ++ func ++ " is " ++ show n) + `catchError` (say . show) typeChecks (f ++ "==" ++ rubyVal )) functions say $ "Exportable: " ++ (show exportable) @@ -76,6 +76,7 @@ genC exportable zmoduleName= unlines $ ,"#include " ,"#define HAVE_STRUCT_TIMESPEC 1" ,"#include " +-- ,"#define DEBUG 1" ,"#ifdef DEBUG" ,"#define eprintf printf" ,"#else" @@ -114,8 +115,10 @@ 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;" ," }" ,"}"]