module Control.Monad.Sharing.Implementation.FirstOrder (
Lazy, evalLazy
) where
import Control.Monad ( MonadPlus(..) )
import Control.Monad.Trans ( MonadTrans(..), MonadIO(..) )
import Control.Monad.Sharing.Classes
import qualified Control.Monad.Sharing.Implementation.CPS as CPS
import Control.Monad.Sharing.Implementation.CPS
(
freshLabel, lookupValue, storeValue )
newtype Lazy m a = Lazy { fromLazy :: m (Labeled m a) }
evalLazy :: (Monad m, Shareable (Lazy m) a, Convertible (Lazy m) a b)
=> Lazy m a -> m b
evalLazy m = do Lifted a <- fromLazy (evalS (gnf m) >>= convert)
return a
type S m a = CPS.Lazy m a
evalS :: Monad m => S m a -> m a
evalS m = CPS.runLazy m
data Labeled m a
= Lifted a
| WithFresh (Int -> Lazy m a)
| forall b . Shareable (Lazy m) b => Labeled Int (Lazy m b) (b -> Lazy m a)
gnf :: (Monad m, Shareable (Lazy m) a) => Lazy m a -> S (Lazy m) a
gnf a = hnf a >>= shareArgs (\b -> gnf b >>= return . return)
hnf :: Monad m => Lazy m a -> S (Lazy m) a
hnf m = run =<< lift (lift (fromLazy m))
run :: Monad m => Labeled m a -> S (Lazy m) a
run (Lifted a) = return a
run (WithFresh f) = hnf . f =<< freshLabel
run (Labeled n a f) = do thunk <- lookupValue n
case thunk of
Just c -> hnf (f c)
Nothing -> do x <- labelArgs a
storeValue n x
hnf (f x)
labelArgs :: (Monad m, Shareable (Lazy m) a) => Lazy m a -> S (Lazy m) a
labelArgs a = hnf a >>= shareArgs (\x -> do n <- freshLabel
return (setLabel n x.:a))
(.:) :: Lazy m a -> Lazy m b -> Lazy m a
(.:) = const
setLabel :: (Monad m, Shareable (Lazy m) a) => Int -> Lazy m a -> Lazy m a
setLabel n x = Lazy (return (Labeled n x return))
instance Monad m => Monad (Lazy m)
where
return = Lazy . return . Lifted
a >>= k = Lazy (fromLazy a >>= bind k)
fail = Lazy . fail
bind :: Monad m => (a -> Lazy m b) -> Labeled m a -> m (Labeled m b)
bind k (Lifted a) = fromLazy (k a)
bind k (WithFresh f) = return (WithFresh (\n -> f n >>= k))
bind k (Labeled n m f) = return (Labeled n m (\x -> f x >>= k))
instance MonadPlus m => MonadPlus (Lazy m)
where
mzero = Lazy mzero
a `mplus` b = Lazy (fromLazy a `mplus` fromLazy b)
instance MonadTrans Lazy
where
lift a = Lazy (a >>= return . Lifted)
instance MonadIO m => MonadIO (Lazy m)
where
liftIO = lift . liftIO
instance Monad m => Sharing (Lazy m)
where
share a = Lazy (return (WithFresh (\n -> return (setLabel n a))))