@@ -0,0 +1,59 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+module Data.Swagger.Declare where
8+import Control.Monad.Trans
9+import Data.Functor.Identity
12+newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }
15+instance (Monad m, Monoid d) => Applicative (DeclareT d m) where
16+ pure x = DeclareT (\_ -> pure (mempty, x))
17+ DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
19+ (d'', x) <- dx (d <> d')
20+ return (d' <> d'', f x)
22+instance (Monad m, Monoid d) => Monad (DeclareT d m) where
23+ return x = DeclareT (\_ -> pure (mempty, x))
24+ DeclareT dx >>= f = DeclareT $ \d -> do
26+ (d'', y) <- runDeclareT (f x) (d <> d')
27+ return (d' <> d'', y)
29+instance Monoid d => MonadTrans (DeclareT d) where
30+ lift m = DeclareT (\_ -> (,) mempty <$> m)
32+class Monad m => MonadDeclare d m | m -> d where
36+instance (Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
37+ declare d = DeclareT (\_ -> return (d, ()))
38+ look = DeclareT (\d -> return (mempty, d))
40+looks :: MonadDeclare d m => (d -> a) -> m a
43+evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
44+evalDeclareT (DeclareT f) d = snd `liftM` f d
46+execDeclareT :: Monad m => DeclareT d m a -> d -> m d
47+execDeclareT (DeclareT f) d = fst `liftM` f d
49+type Declare d = DeclareT d Identity
51+runDeclare :: Declare d a -> d -> (d, a)
52+runDeclare m = runIdentity . runDeclareT m
54+evalDeclare :: Declare d a -> d -> a
55+evalDeclare m = runIdentity . evalDeclareT m
57+execDeclare :: Declare d a -> d -> d
58+execDeclare m = runIdentity . execDeclareT m