use exceptions for failed pattern-match

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

Language/Ruby/Hubris/Binding.chs

@@ -63,13 +63,16 @@ 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
 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 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

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 <stdlib.h>"
           ,"#define HAVE_STRUCT_TIMESPEC 1"
           ,"#include <ruby.h>"
+--          ,"#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;"
                               ,"  }"
                               ,"}"]