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 Data.Apiary.SList
import Data.Apiary.Document
import Data.Monoid
import Text.Blaze.Html
import qualified Data.Text as T
import Control.Monad.Apiary.Action.Internal
data ApiaryReader n c = ApiaryReader
{ readerFilter :: ActionT n (SList c)
, readerConfig :: ApiaryConfig
, readerDoc :: Doc -> Doc
}
data ApiaryWriter n = ApiaryWriter
{ writerHandler :: ActionT n ()
, writerDoc :: [Doc]
}
instance Monad n => Monoid (ApiaryWriter n) where
mempty = ApiaryWriter mzero []
ApiaryWriter ah ad `mappend` ApiaryWriter bh bd =
ApiaryWriter (mplus ah bh) (ad <> bd)
initialReader :: Monad n => ApiaryConfig -> ApiaryReader n '[]
initialReader conf = ApiaryReader (return SNil) conf id
newtype ApiaryT c n m a = ApiaryT { unApiaryT :: forall b.
ApiaryReader n c
-> (a -> ApiaryWriter n -> m b)
-> m b
}
type Apiary c = ApiaryT c IO Identity
instance Functor (ApiaryT c n m) where
fmap f m = ApiaryT $ \rdr cont ->
unApiaryT m rdr $ \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 $ \rdr cont ->
unApiaryT mf rdr $ \f hdr ->
unApiaryT ma rdr $ \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 $ \rdr cont ->
unApiaryT m rdr $ \a hdr ->
unApiaryT (k a) rdr $ \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
apiaryT :: Monad m
=> (ApiaryReader n c -> m (a, ApiaryWriter n))
-> ApiaryT c n m a
apiaryT f = ApiaryT $ \rdr cont -> f rdr >>= \(a,w) -> cont a w
instance Monad n => MonadTransControl (ApiaryT c n) where
newtype StT (ApiaryT c n) a = StTApiary' { unStTApiary' :: (a, ApiaryWriter n) }
liftWith f = apiaryT $ \rdr ->
liftM (\a -> (a, mempty))
(f $ \t -> liftM StTApiary' $ unApiaryT t rdr (\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'
runApiaryT' :: (Monad n, Monad m) => (forall b. n b -> IO b) -> ApiaryConfig
-> ApiaryT '[] n m a -> m (Application, Documents)
runApiaryT' run conf m = unApiaryT m (initialReader conf) (\_ w -> return w) >>= \wtr -> do
let doc = docsToDocuments $ writerDoc wtr
da = maybe mzero (\f -> f doc) $ documentationAction conf
app = execActionT conf $ hoistActionT run (writerHandler wtr) `mplus` da
return (app, doc)
runApiaryT :: (Monad n, Monad m) => (forall b. n b -> IO b) -> ApiaryConfig
-> ApiaryT '[] n m a -> m Application
runApiaryT run conf m = fst `liftM` runApiaryT' run conf m
runApiary :: ApiaryConfig -> Apiary '[] a -> Application
runApiary conf m = runIdentity $ runApiaryT id conf m
apiaryConfig :: Monad n => ApiaryT c n m ApiaryConfig
apiaryConfig = ApiaryT $ \r cont -> cont (readerConfig r) mempty
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 $ \rdr cont -> unApiaryT m rdr
{ readerFilter = readerFilter rdr >>= g
, readerDoc = readerDoc rdr . d
} cont
action :: Monad n => Fn c (ActionT n ()) -> ApiaryT c n m ()
action = action' . apply
group :: T.Text -> ApiaryT c n m a -> ApiaryT c n m a
group d m = ApiaryT $ \rdr cont -> unApiaryT m rdr
{ readerDoc = readerDoc rdr . DocGroup d } cont
document :: T.Text -> ApiaryT c n m a -> ApiaryT c n m a
document d m = ApiaryT $ \rdr cont -> unApiaryT m rdr
{ readerDoc = \_ -> readerDoc rdr (Document $ Just d) } cont
precondition :: Html -> ApiaryT c n m a -> ApiaryT c n m a
precondition d m = ApiaryT $ \rdr cont -> unApiaryT m rdr
{ readerDoc = readerDoc rdr . DocPrecondition d } cont
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
getReader :: Monad n => ApiaryT c n m (ApiaryReader n c)
getReader = ApiaryT $ \rdr cont -> cont rdr mempty
action' :: Monad n => (SList c -> ActionT n ()) -> ApiaryT c n m ()
action' a = do
rdr <- getReader
addRoute $ ApiaryWriter (readerFilter rdr >>= \c -> a c)
[readerDoc rdr $ Document Nothing]