module Control.Monad.Apiary.Internal where
import Network.Wai
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Control
import Control.Monad.Base
import Data.Monoid
import Data.Apiary.SList
import Control.Monad.Apiary.Action.Internal
newtype Apiary c a = Apiary { unApiary :: forall b.
Action (SList c)
-> ApiaryConfig
-> (a -> Action () -> IO b)
-> IO b
}
instance Functor (Apiary c) where
fmap f m = Apiary $ \grd conf cont ->
unApiary m grd conf $ \a hdr -> hdr `seq` cont (f a) hdr
instance Applicative (Apiary c) where
pure x = Apiary $ \_ _ cont -> cont x mempty
mf <*> ma = Apiary $ \grd conf cont ->
unApiary mf grd conf $ \f hdr ->
unApiary ma grd conf $ \a hdr' ->
let hdr'' = hdr <> hdr'
in hdr'' `seq` cont (f a) hdr''
instance Monad (Apiary c) where
return x = Apiary $ \_ _ cont -> cont x mempty
m >>= k = Apiary $ \grd conf cont ->
unApiary m grd conf $ \a hdr ->
unApiary (k a) grd conf $ \b hdr' ->
let hdr'' = hdr <> hdr'
in hdr'' `seq` cont b hdr''
instance MonadIO (Apiary c) where
liftIO m = Apiary $ \_ _ c -> m >>= \a -> c a mempty
instance MonadBase IO (Apiary c) where
liftBase = liftIO
apiary :: (Action (SList c) -> ApiaryConfig -> IO (a,Action ())) -> Apiary c a
apiary f = Apiary $ \grd conf cont -> f grd conf >>= \(a,w) -> cont a w
run :: Apiary c a -> Action (SList c) -> ApiaryConfig -> IO (a, Action ())
run m grd conf = unApiary m grd conf $ \a w -> return (a,w)
instance MonadBaseControl IO (Apiary c) where
newtype StM (Apiary c) a = StMApiary { unStMApiary :: (a, Action ()) }
liftBaseWith f = apiary $ \g c ->
liftM (\a -> (a, mempty)) (f $ \t -> liftM StMApiary $ run t g c)
restoreM m = apiary $ \_ _ -> return (unStMApiary m)
runApiary :: ApiaryConfig -> Apiary '[] a -> Application
runApiary conf m req = unApiary m (return SNil) conf (\_ w -> return w) >>= \a ->
execAction conf a req
getGuard :: Apiary c (Action (SList c))
getGuard = Apiary $ \grd _ c -> c grd mempty
apiaryConfig :: Apiary c ApiaryConfig
apiaryConfig = Apiary $ \_ c cont -> cont c mempty
addRoute :: Action () -> Apiary c ()
addRoute r = Apiary $ \_ _ cont -> cont () r
focus :: (SList c -> Action (SList c')) -> Apiary c' a -> Apiary c a
focus g m = do
Apiary $ \grd cfg cont ->
unApiary m (grd >>= g) cfg cont
action :: Fn c (Action ()) -> Apiary c ()
action = actionWithPreAction (const $ return ())
actionWithPreAction :: (SList xs -> Action a)
-> Fn xs (Action ()) -> Apiary xs ()
actionWithPreAction pa a = do
grd <- getGuard
addRoute $ grd >>= \c -> (pa c) >> apply a c