module Control.Monad.Trans.Fraxl
(
FreerT
, Fraxl
, Fetch
, runFraxl
, simpleAsyncFetch
, fetchNil
, (|:|)
, hoistFetch
, transFetch
, ASeq(..)
, reduceASeq
, hoistASeq
, traverseASeq
, rebaseASeq
, CachedFetch(..)
, fetchCached
, runCachedFraxl
, evalCachedFraxl
, module Data.GADT.Compare
, Union(..)
, getCoRec
, mkUnion
) where
import Control.Applicative.Fraxl.Free
import Control.Arrow
import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State
import Control.Monad.Trans.Fraxl.Free
import Data.Dependent.Map (DMap)
import qualified Data.Dependent.Map as DMap
import Data.GADT.Compare
import qualified Data.Vinyl.Prelude.CoRec as CR
import Data.Vinyl.Types
type FreerT f = FreeT (Ap f)
type Fraxl r = FreerT (Union r)
type Fetch f m a = ASeq f a -> m (ASeq m a)
fetchNil :: Applicative m => Fetch (Union '[]) m a
fetchNil ANil = pure ANil
fetchNil _ = error "Not possible - empty union"
(|:|) :: forall f r a m. Monad m
=> (forall a'. Fetch f m a')
-> (forall a'. Fetch (Union r) m a')
-> Fetch (Union (f ': r)) m a
(fetch |:| fetchU) list = (\(_, _, x) -> x) <$> runUnion ANil ANil list where
runUnion :: ASeq f x
-> ASeq (Union r) y
-> ASeq (Union (f ': r)) z
-> m (ASeq m x, ASeq m y, ASeq m z)
runUnion flist ulist ANil = (, , ANil) <$> fetch flist <*> fetchU ulist
runUnion flist ulist (ACons u us) = case CR.uncons (getCoRec u) of
Left (Flap fa) -> fmap
(\(ACons ma ms, other, rest) -> (ms, other, ACons ma rest))
(runUnion (ACons fa flist) ulist us)
Right u' -> fmap
(\(other, ACons ma ms, rest) -> (other, ms, ACons ma rest))
(runUnion flist (ACons (mkUnion u') ulist) us)
infixr 5 |:|
hoistFetch :: Functor m => (forall x. m x -> n x) -> Fetch f m a -> Fetch f n a
hoistFetch u f = u . fmap (hoistASeq u) . f
transFetch :: (forall x. g x -> f x) -> Fetch f m a -> Fetch g m a
transFetch u f list = f (hoistASeq u list)
runFraxl :: Monad m => (forall a'. Fetch f m a') -> FreerT f m a -> m a
runFraxl fetch = iterT $ \a -> unAp a
(\f s -> join (reduceASeq <$> fetch s) >>= f) (const id) ANil
simpleAsyncFetch :: MonadIO m
=> (forall x. f x -> IO x)
-> Fetch f m a
simpleAsyncFetch fetchIO
= traverseASeq (fmap (liftIO . wait) . liftIO . async . fetchIO)
newtype CachedFetch f a = CachedFetch (f a)
fetchCached :: forall t m f a.
( Monad m
, MonadTrans t
, MonadState (DMap f MVar) (t m)
, GCompare f
, MonadIO (t m))
=> (forall a'. Fetch f m a') -> Fetch (CachedFetch f) (t m) a
fetchCached fetch list = snd <$> runCached ANil list where
runCached :: ASeq f x
-> ASeq (CachedFetch f) y
-> t m (ASeq (t m) x, ASeq (t m) y)
runCached flist ANil = (, ANil) <$> lift (hoistASeq lift <$> fetch flist)
runCached flist (ACons (CachedFetch f) fs) = do
cache <- get
case DMap.lookup f cache of
Just mvar -> fmap
(second (ACons (liftIO $ readMVar mvar)))
(runCached flist fs)
Nothing -> do
(mvar :: MVar z) <- liftIO newEmptyMVar
put (DMap.insert f mvar cache)
let store :: t m z -> t m z
store m = m >>= \a -> liftIO (putMVar mvar a) >> return a
fmap
(\(ACons m ms, rest) -> (ms, ACons (store m) rest))
(runCached (ACons f flist) fs)
runCachedFraxl :: forall m f a.
( MonadIO m
, GCompare f)
=> (forall a'. Fetch f m a')
-> FreerT f m a
-> DMap f MVar
-> m (a, DMap f MVar)
runCachedFraxl fetch a cache = let
cachedA :: FreerT (CachedFetch f) (StateT (DMap f MVar) m) a
cachedA = transFreeT (hoistAp CachedFetch) (hoistFreeT lift a)
in runStateT (runFraxl (fetchCached fetch) cachedA) cache
evalCachedFraxl :: forall m f a.
( MonadIO m
, GCompare f)
=> (forall a'. Fetch f m a') -> FreerT f m a -> m a
evalCachedFraxl fetch a = fst <$> runCachedFraxl fetch a DMap.empty
newtype Union r a = Union (FunctorCoRec r a)
getCoRec :: Union r a -> CoRec (Flap a) r
getCoRec (Union (FunctorCoRec u)) = u
mkUnion :: CoRec (Flap a) r -> Union r a
mkUnion u = Union $ FunctorCoRec u
instance GEq (Union '[]) where
_ `geq` _ = error "Not possible - empty union"
instance (GEq f, GEq (Union r)) => GEq (Union (f ': r)) where
a `geq` b = case (CR.uncons (getCoRec a), CR.uncons (getCoRec b)) of
(Left (Flap fa), Left (Flap fb)) -> fa `geq` fb
(Right a', Right b') -> mkUnion a' `geq` mkUnion b'
_ -> Nothing
instance GCompare (Union '[]) where
_ `gcompare` _ = error "Not possible - empty union"
instance (GCompare f, GCompare (Union r)) => GCompare (Union (f ': r)) where
a `gcompare` b = case (CR.uncons (getCoRec a), CR.uncons (getCoRec b)) of
(Left (Flap fa), Left (Flap fb)) -> fa `gcompare` fb
(Right a', Right b') -> mkUnion a' `gcompare` mkUnion b'
(Left _, Right _) -> GLT
(Right _, Left _) -> GGT