@@ -0,0 +1,59 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+module Data.Swagger.Declare where
6+
7+import Control.Monad
8+import Control.Monad.Trans
9+import Data.Functor.Identity
10+import Data.Monoid
11+
12+newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }
13+ deriving (Functor)
14+
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
18+ (d', f) <- df d
19+ (d'', x) <- dx (d <> d')
20+ return (d' <> d'', f x)
21+
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
25+ (d', x) <- dx d
26+ (d'', y) <- runDeclareT (f x) (d <> d')
27+ return (d' <> d'', y)
28+
29+instance Monoid d => MonadTrans (DeclareT d) where
30+ lift m = DeclareT (\_ -> (,) mempty <$> m)
31+
32+class Monad m => MonadDeclare d m | m -> d where
33+ declare :: d -> m ()
34+ look :: m d
35+
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))
39+
40+looks :: MonadDeclare d m => (d -> a) -> m a
41+looks f = f <$> look
42+
43+evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
44+evalDeclareT (DeclareT f) d = snd `liftM` f d
45+
46+execDeclareT :: Monad m => DeclareT d m a -> d -> m d
47+execDeclareT (DeclareT f) d = fst `liftM` f d
48+
49+type Declare d = DeclareT d Identity
50+
51+runDeclare :: Declare d a -> d -> (d, a)
52+runDeclare m = runIdentity . runDeclareT m
53+
54+evalDeclare :: Declare d a -> d -> a
55+evalDeclare m = runIdentity . evalDeclareT m
56+
57+execDeclare :: Declare d a -> d -> d
58+execDeclare m = runIdentity . execDeclareT m
59+