module Control.Monad.Apiary.Internal where
import Network.Wai
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Identity
import Control.Monad.Trans.Control
import Control.Monad.Base
import Control.Monad.Apiary.Action.Internal
import Data.Apiary.SList
import Data.Apiary.Document
import Data.Monoid
import Text.Blaze.Html
import qualified Data.Text as T
data ApiaryEnv n c = ApiaryEnv
{ envFilter :: ActionT n (SList c)
, envConfig :: ApiaryConfig
, envDoc :: Doc -> Doc
}
initialEnv :: Monad n => ApiaryConfig -> ApiaryEnv n '[]
initialEnv conf = ApiaryEnv (return SNil) conf id
data ApiaryWriter n = ApiaryWriter
{ writerHandler :: ActionT n ()
, writerDoc :: [Doc]
}
newtype ApiaryT c n m a = ApiaryT { unApiaryT :: forall b.
ApiaryEnv n c
-> (a -> ApiaryWriter n -> m b)
-> m b
}
type Apiary c = ApiaryT c IO Identity
apiaryT :: Monad m
=> (ApiaryEnv n c -> m (a, ApiaryWriter n))
-> ApiaryT c n m a
apiaryT f = ApiaryT $ \env cont -> f env >>= \(a,w) -> cont a w
runApiaryT :: (Monad n, Monad m) => (forall b. n b -> IO b) -> ApiaryConfig
-> ApiaryT '[] n m a -> m Application
runApiaryT run conf m = unApiaryT m (initialEnv conf) (\_ w -> return w) >>= \wtr -> do
let doc = docsToDocuments $ writerDoc wtr
app = execActionT conf doc $ hoistActionT run (writerHandler wtr)
return app
runApiary :: ApiaryConfig -> Apiary '[] a -> Application
runApiary conf m = runIdentity $ runApiaryT id conf m
instance Monad n => Monoid (ApiaryWriter n) where
mempty = ApiaryWriter mzero []
ApiaryWriter ah ad `mappend` ApiaryWriter bh bd =
ApiaryWriter (mplus ah bh) (ad <> bd)
instance Functor (ApiaryT c n m) where
fmap f m = ApiaryT $ \env cont ->
unApiaryT m env $ \a hdr -> hdr `seq` cont (f a) hdr
instance Monad n => Applicative (ApiaryT c n m) where
pure x = ApiaryT $ \_ cont -> cont x mempty
mf <*> ma = ApiaryT $ \env cont ->
unApiaryT mf env $ \f hdr ->
unApiaryT ma env $ \a hdr' ->
let hdr'' = hdr <> hdr'
in hdr'' `seq` cont (f a) hdr''
instance Monad n => Monad (ApiaryT c n m) where
return x = ApiaryT $ \_ cont -> cont x mempty
m >>= k = ApiaryT $ \env cont ->
unApiaryT m env $ \a hdr ->
unApiaryT (k a) env $ \b hdr' ->
let hdr'' = hdr <> hdr'
in hdr'' `seq` cont b hdr''
instance Monad n => MonadTrans (ApiaryT c n) where
lift m = ApiaryT $ \_ c -> m >>= \a -> c a mempty
instance (Monad n, MonadIO m) => MonadIO (ApiaryT c n m) where
liftIO m = ApiaryT $ \_ c -> liftIO m >>= \a -> c a mempty
instance (Monad n, MonadBase b m) => MonadBase b (ApiaryT c n m) where
liftBase m = ApiaryT $ \_ c -> liftBase m >>= \a -> c a mempty
instance Monad n => MonadTransControl (ApiaryT c n) where
newtype StT (ApiaryT c n) a = StTApiary' { unStTApiary' :: (a, ApiaryWriter n) }
liftWith f = apiaryT $ \env ->
liftM (\a -> (a, mempty))
(f $ \t -> liftM StTApiary' $ unApiaryT t env (\a w -> return (a,w)))
restoreT m = apiaryT $ \_ -> liftM unStTApiary' m
instance (Monad n, MonadBaseControl b m) => MonadBaseControl b (ApiaryT c n m) where
newtype StM (ApiaryT c n m) a = StMApiary' { unStMApiary' :: ComposeSt (ApiaryT c n) m a }
liftBaseWith = defaultLiftBaseWith StMApiary'
restoreM = defaultRestoreM unStMApiary'
getApiaryEnv :: Monad n => ApiaryT c n m (ApiaryEnv n c)
getApiaryEnv = ApiaryT $ \env cont -> cont env mempty
apiaryConfig :: Monad n => ApiaryT c n m ApiaryConfig
apiaryConfig = liftM envConfig getApiaryEnv
addRoute :: Monad n => ApiaryWriter n -> ApiaryT c n m ()
addRoute r = ApiaryT $ \_ cont -> cont () r
focus :: Monad n => (Doc -> Doc) -> (SList c -> ActionT n (SList c'))
-> ApiaryT c' n m a -> ApiaryT c n m a
focus d g m = ApiaryT $ \env cont -> unApiaryT m env
{ envFilter = envFilter env >>= g
, envDoc = envDoc env . d
} cont
action :: Monad n => Fn c (ActionT n ()) -> ApiaryT c n m ()
action = action' . apply
action' :: Monad n => (SList c -> ActionT n ()) -> ApiaryT c n m ()
action' a = do
env <- getApiaryEnv
addRoute $ ApiaryWriter (envFilter env >>= \c -> a c)
[envDoc env Action]
insDoc :: (Doc -> Doc) -> ApiaryT c n m a -> ApiaryT c n m a
insDoc d m = ApiaryT $ \env cont -> unApiaryT m env
{ envDoc = envDoc env . d } cont
group :: T.Text -> ApiaryT c n m a -> ApiaryT c n m a
group = insDoc . DocGroup
document :: T.Text -> ApiaryT c n m a -> ApiaryT c n m a
document = insDoc . Document
precondition :: Html -> ApiaryT c n m a -> ApiaryT c n m a
precondition = insDoc . DocPrecondition
noDoc :: ApiaryT c n m a -> ApiaryT c n m a
noDoc = insDoc DocDropNext
actionWithPreAction :: Monad n => (SList xs -> ActionT n a)
-> Fn xs (ActionT n ()) -> ApiaryT xs n m ()
actionWithPreAction pa a = do
action' $ \c -> pa c >> apply a c