{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

--------------------------------------------------------------------
-- |
-- Module    : Data.Ruby.Marshal.Monad
-- Copyright : (c) Philip Cunningham, 2015
-- License   : MIT
--
-- Maintainer:  hello@filib.io
-- Stability :  experimental
-- Portability: portable
--
-- Marshal monad provides an object cache over the Get monad.
--
--------------------------------------------------------------------

module Data.Ruby.Marshal.Monad where

import           Control.Applicative
import qualified Control.Monad.Fail           as Fail
import qualified Control.Monad                as Monad
import           Control.Monad                (join)
import           Control.Monad.State.Strict   (MonadState, StateT, get, gets,
                                               lift, put)
import           Data.Ruby.Marshal.RubyObject (RubyObject (..))
import           Data.Serialize.Get           (Get)
import           Data.Vector                  (Vector)
import qualified Data.Vector                  as V
import           Prelude

-- | Marshal monad endows the underlying Get monad with State.
newtype Marshal a = Marshal {
  Marshal a -> StateT Cache Get a
runMarshal :: StateT Cache Get a
} deriving (a -> Marshal b -> Marshal a
(a -> b) -> Marshal a -> Marshal b
(forall a b. (a -> b) -> Marshal a -> Marshal b)
-> (forall a b. a -> Marshal b -> Marshal a) -> Functor Marshal
forall a b. a -> Marshal b -> Marshal a
forall a b. (a -> b) -> Marshal a -> Marshal b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Marshal b -> Marshal a
$c<$ :: forall a b. a -> Marshal b -> Marshal a
fmap :: (a -> b) -> Marshal a -> Marshal b
$cfmap :: forall a b. (a -> b) -> Marshal a -> Marshal b
Functor, Functor Marshal
a -> Marshal a
Functor Marshal
-> (forall a. a -> Marshal a)
-> (forall a b. Marshal (a -> b) -> Marshal a -> Marshal b)
-> (forall a b c.
    (a -> b -> c) -> Marshal a -> Marshal b -> Marshal c)
-> (forall a b. Marshal a -> Marshal b -> Marshal b)
-> (forall a b. Marshal a -> Marshal b -> Marshal a)
-> Applicative Marshal
Marshal a -> Marshal b -> Marshal b
Marshal a -> Marshal b -> Marshal a
Marshal (a -> b) -> Marshal a -> Marshal b
(a -> b -> c) -> Marshal a -> Marshal b -> Marshal c
forall a. a -> Marshal a
forall a b. Marshal a -> Marshal b -> Marshal a
forall a b. Marshal a -> Marshal b -> Marshal b
forall a b. Marshal (a -> b) -> Marshal a -> Marshal b
forall a b c. (a -> b -> c) -> Marshal a -> Marshal b -> Marshal c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Marshal a -> Marshal b -> Marshal a
$c<* :: forall a b. Marshal a -> Marshal b -> Marshal a
*> :: Marshal a -> Marshal b -> Marshal b
$c*> :: forall a b. Marshal a -> Marshal b -> Marshal b
liftA2 :: (a -> b -> c) -> Marshal a -> Marshal b -> Marshal c
$cliftA2 :: forall a b c. (a -> b -> c) -> Marshal a -> Marshal b -> Marshal c
<*> :: Marshal (a -> b) -> Marshal a -> Marshal b
$c<*> :: forall a b. Marshal (a -> b) -> Marshal a -> Marshal b
pure :: a -> Marshal a
$cpure :: forall a. a -> Marshal a
$cp1Applicative :: Functor Marshal
Applicative, MonadState Cache)

instance Monad Marshal where
  (Marshal StateT Cache Get a
ma) >>= :: Marshal a -> (a -> Marshal b) -> Marshal b
>>= a -> Marshal b
f = StateT Cache Get b -> Marshal b
forall a. StateT Cache Get a -> Marshal a
Marshal (StateT Cache Get b -> Marshal b)
-> (StateT Cache Get (StateT Cache Get b) -> StateT Cache Get b)
-> StateT Cache Get (StateT Cache Get b)
-> Marshal b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT Cache Get (StateT Cache Get b) -> StateT Cache Get b
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (StateT Cache Get (StateT Cache Get b) -> Marshal b)
-> StateT Cache Get (StateT Cache Get b) -> Marshal b
forall a b. (a -> b) -> a -> b
$ Marshal b -> StateT Cache Get b
forall a. Marshal a -> StateT Cache Get a
runMarshal (Marshal b -> StateT Cache Get b)
-> (a -> Marshal b) -> a -> StateT Cache Get b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Marshal b
f (a -> StateT Cache Get b)
-> StateT Cache Get a -> StateT Cache Get (StateT Cache Get b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Cache Get a
ma

#if !MIN_VERSION_base(4,13,0)
  fail = Fail.fail
#endif

instance Fail.MonadFail Marshal where
  fail :: String -> Marshal a
fail = StateT Cache Get a -> Marshal a
forall a. StateT Cache Get a -> Marshal a
Marshal (StateT Cache Get a -> Marshal a)
-> (String -> StateT Cache Get a) -> String -> Marshal a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StateT Cache Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
Monad.fail

-- | Lift Get monad into Marshal monad.
liftMarshal :: Get a -> Marshal a
liftMarshal :: Get a -> Marshal a
liftMarshal = StateT Cache Get a -> Marshal a
forall a. StateT Cache Get a -> Marshal a
Marshal (StateT Cache Get a -> Marshal a)
-> (Get a -> StateT Cache Get a) -> Get a -> Marshal a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get a -> StateT Cache Get a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | State that we must carry around during deserialisation.
data Cache = Cache {
    Cache -> Vector RubyObject
objects :: !(Vector RubyObject)
    -- ^ object cache.
  , Cache -> Vector RubyObject
symbols :: !(Vector RubyObject)
    -- ^ symbol cache.
} deriving Int -> Cache -> ShowS
[Cache] -> ShowS
Cache -> String
(Int -> Cache -> ShowS)
-> (Cache -> String) -> ([Cache] -> ShowS) -> Show Cache
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cache] -> ShowS
$cshowList :: [Cache] -> ShowS
show :: Cache -> String
$cshow :: Cache -> String
showsPrec :: Int -> Cache -> ShowS
$cshowsPrec :: Int -> Cache -> ShowS
Show

-- | Constructs an empty cache to store symbols and objects.
emptyCache :: Cache
emptyCache :: Cache
emptyCache = Cache :: Vector RubyObject -> Vector RubyObject -> Cache
Cache { symbols :: Vector RubyObject
symbols = Vector RubyObject
forall a. Vector a
V.empty, objects :: Vector RubyObject
objects = Vector RubyObject
forall a. Vector a
V.empty }

-- | Look up value in cache.
readCache :: Int -> (Cache -> Vector RubyObject) -> Marshal (Maybe RubyObject)
readCache :: Int -> (Cache -> Vector RubyObject) -> Marshal (Maybe RubyObject)
readCache Int
index Cache -> Vector RubyObject
f = (Cache -> Vector RubyObject) -> Marshal (Vector RubyObject)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Cache -> Vector RubyObject
f Marshal (Vector RubyObject)
-> (Vector RubyObject -> Marshal (Maybe RubyObject))
-> Marshal (Maybe RubyObject)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Vector RubyObject
cache -> Maybe RubyObject -> Marshal (Maybe RubyObject)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe RubyObject -> Marshal (Maybe RubyObject))
-> Maybe RubyObject -> Marshal (Maybe RubyObject)
forall a b. (a -> b) -> a -> b
$ Vector RubyObject
cache Vector RubyObject -> Int -> Maybe RubyObject
forall a. Vector a -> Int -> Maybe a
V.!? Int
index

-- | Look up object in object cache.
readObject :: Int -> Marshal (Maybe RubyObject)
readObject :: Int -> Marshal (Maybe RubyObject)
readObject Int
index = Int -> (Cache -> Vector RubyObject) -> Marshal (Maybe RubyObject)
readCache Int
index Cache -> Vector RubyObject
objects

-- | Look up a symbol in symbol cache.
readSymbol :: Int -> Marshal (Maybe RubyObject)
readSymbol :: Int -> Marshal (Maybe RubyObject)
readSymbol Int
index = Int -> (Cache -> Vector RubyObject) -> Marshal (Maybe RubyObject)
readCache Int
index Cache -> Vector RubyObject
symbols

-- | Write an object to the appropriate cache.
writeCache :: RubyObject -> Marshal ()
writeCache :: RubyObject -> Marshal ()
writeCache RubyObject
object = do
  Cache
cache <- Marshal Cache
forall s (m :: * -> *). MonadState s m => m s
get
  case RubyObject
object of
    RSymbol ByteString
_ -> do
      Cache -> Marshal ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Cache -> Marshal ()) -> Cache -> Marshal ()
forall a b. (a -> b) -> a -> b
$ Cache
cache { symbols :: Vector RubyObject
symbols = Vector RubyObject -> RubyObject -> Vector RubyObject
forall a. Vector a -> a -> Vector a
V.snoc (Cache -> Vector RubyObject
symbols Cache
cache) RubyObject
object }
    RIVar (RubyObject, RubyStringEncoding)
_   -> do
      Cache -> Marshal ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Cache -> Marshal ()) -> Cache -> Marshal ()
forall a b. (a -> b) -> a -> b
$ Cache
cache { objects :: Vector RubyObject
objects = Vector RubyObject -> RubyObject -> Vector RubyObject
forall a. Vector a -> a -> Vector a
V.snoc (Cache -> Vector RubyObject
objects Cache
cache) RubyObject
object }
    RArray Vector RubyObject
_   -> do
      Cache -> Marshal ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Cache -> Marshal ()) -> Cache -> Marshal ()
forall a b. (a -> b) -> a -> b
$ Cache
cache { objects :: Vector RubyObject
objects = Vector RubyObject -> RubyObject -> Vector RubyObject
forall a. Vector a -> a -> Vector a
V.snoc (Cache -> Vector RubyObject
objects Cache
cache) RubyObject
object }
    RHash Vector (RubyObject, RubyObject)
_   -> do
      Cache -> Marshal ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Cache -> Marshal ()) -> Cache -> Marshal ()
forall a b. (a -> b) -> a -> b
$ Cache
cache { objects :: Vector RubyObject
objects = Vector RubyObject -> RubyObject -> Vector RubyObject
forall a. Vector a -> a -> Vector a
V.snoc (Cache -> Vector RubyObject
objects Cache
cache) RubyObject
object }
    RubyObject
_         -> () -> Marshal ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()