Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

tightening up some Rubyable/Haskellable instances, whitespace fixes

  • Loading branch information...
commit 17f3fc39eec601434f76b3a9405cd9fefd3c8890 1 parent 5fa1e22
@mwotton authored
Showing with 38 additions and 73 deletions.
  1. +38 −73 Haskell/Language/Ruby/Hubris.hs
View
111 Haskell/Language/Ruby/Hubris.hs
@@ -25,13 +25,13 @@ import Data.Typeable
class Callable a where
arity :: a -> Int
-
+
instance (Callable b, Haskellable a) => Callable (a -> b) where
arity x = 1 + arity (undefined :: b)
-
+
instance Rubyable a => Callable a where
arity x = 0
-
+
-- with thanks to copumpkin on #haskell and twitter
-- wrap :: (Haskellable a, Rubyable b) => (a->b) -> (Value -> Value)
@@ -41,7 +41,7 @@ instance Rubyable a => Callable a where
-- Right a -> return a
-- -- wrapIO too? Is there a more generic way of doin
-- g this? would need a = a', b = IO c, so Rubyable b => Rubyable (IO c). (Throw away Show constraint, not necessary)
-
+
data HubrisException = HubrisException String
deriving(Show, Typeable)
@@ -49,9 +49,9 @@ data HubrisException = HubrisException String
instance Exception HubrisException
-- utility stuff:
-sshow :: S.ByteString -> [Char]
+sshow :: S.ByteString -> String
sshow s = Prelude.map w2c $S.unpack s
-lshow :: L.ByteString -> [Char]
+lshow :: L.ByteString -> String
lshow s = Prelude.map w2c $L.unpack s
-- debugging only
@@ -60,7 +60,7 @@ traces :: b -> String -> b
traces = flip trace
when :: Value -> RubyType -> a -> a
-when v b c = if (rubyType v == b)
+when v b c = if rubyType v == b
then c
else trace (show (rubyType v,b)) $ throw (HubrisException "failed in when")
@@ -103,18 +103,19 @@ instance (Haskellable a, Haskellable b, Haskellable c) => Haskellable (a,b,c) wh
instance Rubyable Int where
- toRuby i = int2fix i
+ toRuby = int2fix
instance Rubyable a => Rubyable (IO a) where
- toRuby a = unsafePerformIO (a >>= return . toRuby)
+ toRuby = unsafePerformIO . liftM toRuby
+
instance Haskellable Integer where
toHaskell v = case rubyType v of
- RT_BIGNUM -> trace ("got a big") $ read $ unsafePerformIO (rb_big2str v 10 >>= str2cstr >>= peekCString)
- RT_FIXNUM -> trace("got a fix") $ fromIntegral $ fix2int v
+ RT_BIGNUM -> trace "got a big" $ read $ unsafePerformIO (rb_big2str v 10 >>= str2cstr >>= peekCString)
+ RT_FIXNUM -> trace "got a fix" $ fromIntegral $ fix2int v
_ -> throw (HubrisException "Integer") -- wonder if it's kosher to just let the pattern match fail...
instance Rubyable Integer where
- toRuby i = trace ("integer to ruby") $ rb_str_to_inum (unsafePerformIO $ (newCAString $ show i) >>= rb_str_new2) 10 1
+ toRuby i = trace "integer to ruby" $ rb_str_to_inum (unsafePerformIO $ newCAString (show i) >>= rb_str_new2) 10 1
instance Haskellable Bool where
toHaskell v = case rubyType v of
@@ -127,7 +128,7 @@ instance Rubyable Bool where
toRuby False = constToRuby RUBY_Qfalse
instance Rubyable Double where
- toRuby d = rb_float_new d
+ toRuby = rb_float_new
instance Haskellable Double where
toHaskell v = case rubyType v of
@@ -143,13 +144,12 @@ instance Haskellable Value where
instance Haskellable S.ByteString where
- toHaskell v = when v RT_STRING $ unsafePerformIO $
+ toHaskell v = when v RT_STRING $ unsafePerformIO $
str2cstr v >>= S.packCString >>= \a -> return a `traces` ("strict to Haskell: " ++ sshow a)
instance Rubyable S.ByteString where
toRuby s = unsafePerformIO $ S.useAsCStringLen s rb_str_new
-- \(cs,len) -> rb_str_new (cs,len) --`traces` ("sstrict back to ruby:" ++ (show $ S.unpack s))
-
instance Rubyable () where
toRuby () = toRuby True -- ???
@@ -162,14 +162,14 @@ instance Rubyable L.ByteString where
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]
+ 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
+ toRuby l = unsafePerformIO $ with
+ (rb_ary_new2 $ fromIntegral $ Prelude.length l)
+ (\ary -> mapM_ (rb_ary_push ary . toRuby) l)
-- this one is probably horribly inefficient.
instance (Integral a, Ix a, Haskellable b) => Haskellable (Array a b) where
@@ -177,7 +177,7 @@ instance (Integral a, Ix a, Haskellable b) => Haskellable (Array a b) where
-- 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
+ toRuby = toRuby . Data.Array.IArray.elems
instance Haskellable RubyHash where
toHaskell v = when v RT_HASH $ RubyHash v
@@ -187,68 +187,33 @@ instance Rubyable RubyHash where
-- Nil maps to Nothing - all the other falsey values map to real haskell values.
-instance Haskellable a => Haskellable (Maybe a) where
+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
+with :: Monad m => m a -> (a -> m ()) -> m a
+with creator mutator = do
+ seed <- creator
+ mutator seed
+ return seed
+
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
+ toRuby s = unsafePerformIO $ with rb_hash_new
+ (\hash -> mapM_ (\(k,v) -> rb_hash_aset hash (toRuby k) (toRuby v))
+ (toList s))
+
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 -- putStrLn "Bringing hash over"
- keys <- rb_keys hash
- -- putStrLn ("got the keys: " ++ show keys)
- l :: [Value] <- toHaskell <$> rb_keys hash
-
- r <- foldM (\m k -> do -- putStrLn $ "Key is " ++ show k
- val <- rb_hash_aref hash k
- -- putStrLn $ "Val is " ++ show val
- return $ Map.insert (toHaskell k)
- (toHaskell val)
- m)
- Map.empty l
- return r
-
-
-
--- 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
--- up a Data.Map object in the natural way a bit tricky.
-
--- current thoughts:
--- 1. write a direct binding to the ruby API, include a C level function for getting the keys.
--- just eat the cost of transferring through a keys call + looping over the elements.
--- One big benefit - while iteration is expensive, using it as a hash table should be cheap
--- (although probably needs to stay in the IO monad, which is less convenient.)
---
--- 2. write a binding to the Judy library that creates a Judy object directly. If we can convince
--- HsJudy to accept that, then we're golden - we still have to copy over, but keys operations
--- should be cheap (and hopefully lazy, but test to make sure).
---
--- These are of course not mutually exclusive.
---
--- The first should probably be a part of the base package. The second needs access to internals,
--- but should probably be an optional package. This means that in Hubris.Internals, we should expose
-
--- > rb_foreach :: Value {- HASH -} -> (CFunction ((Key,Value,a) -> a)) -> a -> IO a
---
---
-
--- instance Haskellable (Map.Map a b ) where
--- toHaskell (T_HASH s) = unsafePerformIO $
--- get_each
-
--- toHaskell _ = Nothing
+ toHaskell hash = when hash RT_HASH . unsafePerformIO $
+ toHaskell <$> rb_keys hash >>= foldM (\m k -> (\val -> Map.insert (toHaskell k)
+ (toHaskell val)
+ m)
+ <$> rb_hash_aref hash k)
+ Map.empty
Please sign in to comment.
Something went wrong with that request. Please try again.