{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE Safe #-}
-- | Create unique Enumerable values.
module Control.Eff.Fresh( Fresh (Fresh)
, withFresh
, fresh
, runFresh'
) where
import Control.Eff
import Control.Eff.Extend
import Control.Monad.Base
import Control.Monad.Trans.Control
import Data.Function (fix)
-- There are three possible implementations
-- The first one uses State Fresh where
-- newtype Fresh = Fresh Int
-- We get the `private' effect layer (State Fresh) that does not interfere
-- with with other layers.
-- This is the easiest implementation.
-- The second implementation defines a new effect Fresh
-- | Create unique Enumerable values.
data Fresh v where
Fresh :: Fresh Int
Replace :: !Int -> Fresh ()
-- | Embed a pure value. Note that this is a specialized form of
-- State's and we could have reused it.
withFresh :: Monad m => a -> Int -> m (a, Int)
withFresh x s = return (x, s)
-- | Given a continuation and requests, respond to them
instance Handle Fresh r a (Int -> k) where
handle step q req s = case req of
Fresh -> step (q ^$ s) (s+1)
Replace i -> step (q ^$ ()) i
instance ( MonadBase m m
, LiftedBase m r
) => MonadBaseControl m (Eff (Fresh ': r)) where
type StM (Eff (Fresh ': r)) a = StM (Eff r) (a, Int)
liftBaseWith f = do i <- fresh
raise $ liftBaseWith $ \runInBase ->
f (\k -> runInBase $ runFreshReturn i k)
restoreM x = do (r,i) <- raise (restoreM x)
replace i
return r
-- | Produce a value that has not been previously produced.
fresh :: Member Fresh r => Eff r Int
fresh = send Fresh
replace :: Member Fresh r => Int -> Eff r ()
replace = send . Replace
-- | Run an effect requiring unique values.
runFresh' :: Int -> Eff (Fresh ': r) w -> Eff r w
runFresh' s m = fst `fmap` runFreshReturn s m
runFreshReturn :: Int -> Eff (Fresh ': r) w -> Eff r (w,Int)
runFreshReturn s m = fix (handle_relay withFresh) m s
{-
-- Finally, the worst implementation but the one that answers
-- reviewer's question: implementing Fresh in terms of State
-- but not revealing that fact.
runFresh :: Eff (Fresh :> r) w -> Int -> Eff r w
runFresh m s = runState m' s >>= return . fst
where
m' = loop m
loop (Val x) = return x
loop (E u q) = case decomp u of
Right Fresh -> do
n <- get
put (n+1::Int)
k n
Left u -> send (\k -> weaken $ fmap k u) >>= loop
tfresh = runTrace $ flip runFresh 0 $ do
n <- fresh
-- (x::Int) <- get
trace $ "Fresh " ++ show n
n <- fresh
trace $ "Fresh " ++ show n
{-
If we try to meddle with the encapsulated state, by uncommenting the
get statement above, we get:
No instance for (Member (State Int) Void)
arising from a use of `get'
-}
-}
-- Encapsulation of effects
-- The example suggested by a reviewer
{- The reviewer outlined an MTL implementation below, writing
``This hides the state effect and I can layer another state effect on
top without getting into conflict with the class system.''
class Monad m => MonadFresh m where
fresh :: m Int
newtype FreshT m a = FreshT { unFreshT :: State Int m a }
deriving (Functor, Monad, MonadTrans)
instance Monad m => MonadFresh (FreshT m) where
fresh = FreshT $ do n <- get; put (n+1); return n
See EncapsMTL.hs for the complete code.
-}