{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
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(..)
, unconsCoRec
) where
import Control.Applicative.Free.Fast
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 Data.Sum
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 (Union u) us) = case unconsCoRec u of
Left 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 (Union 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
unconsCoRec :: Sum (t ': ts) f -> Either (t f) (Sum ts f)
unconsCoRec s = case decompose s of
Left s' -> Right s'
Right found -> Left found
newtype Union ts f = Union (Sum ts f)
instance GEq (Union '[]) where
_ `geq` _ = error "Not possible - empty union"
instance (GEq f, GEq (Union r)) => GEq (Union (f ': r)) where
Union a `geq` Union b = case (unconsCoRec a, unconsCoRec b) of
(Left fa, Left fb) -> fa `geq` fb
(Right a', Right b') -> Union a' `geq` Union b'
_ -> Nothing
instance GCompare (Union '[]) where
_ `gcompare` _ = error "Not possible - empty union"
instance (GCompare f, GCompare (Union r)) => GCompare (Union (f ': r)) where
Union a `gcompare` Union b = case (unconsCoRec a, unconsCoRec b) of
(Left fa, Left fb) -> fa `gcompare` fb
(Right a', Right b') -> Union a' `gcompare` Union b'
(Left _, Right _) -> GLT
(Right _, Left _) -> GGT