git.iko.soy/typeable/openapi3
on 29d2ec5 help sign in
typeable/openapi3/src/Data/Swagger/Declare.hs
121 lines 4.0 kB history raw
1{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5module Data.Swagger.Declare where
7import Prelude ()
8import Prelude.Compat
10import Control.Monad
11import Control.Monad.Trans
12import Data.Functor.Identity
13import Data.Monoid
15-- | A declare monad transformer parametrized by:
16--
17-- * @d@ — the output to accumulate (declarations);
18--
19-- * @m@ — the inner monad.
20--
21-- This monad transformer is similar to both state and writer monad transformers.
22-- Thus it can be seen as
23--
24-- * a restricted append-only version of a state monad transformer or
25--
26-- * a writer monad transformer with the extra ability to read all previous output.
27newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }
28 deriving (Functor)
30instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
31 pure x = DeclareT (\_ -> pure (mempty, x))
32 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
33 ~(d', f) <- df d
34 ~(d'', x) <- dx (d <> d')
35 return (d' <> d'', f x)
37instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
38 return x = DeclareT (\_ -> pure (mempty, x))
39 DeclareT dx >>= f = DeclareT $ \d -> do
40 ~(d', x) <- dx d
41 ~(d'', y) <- runDeclareT (f x) (d <> d')
42 return (d' <> d'', y)
44instance Monoid d => MonadTrans (DeclareT d) where
45 lift m = DeclareT (\_ -> (,) mempty `liftM` m)
47-- |
48-- Definitions of @declare@ and @look@ must satisfy the following laws:
49--
50-- [/monoid homomorphism (mempty)/]
51-- @'declare' mempty == return ()@
52--
53-- [/monoid homomorphism (mappend)/]
54-- @'declare' x >> 'declare' y == 'declare' (x <> y)@
55-- for every @x@, @y@
56--
57-- [/@declare@-@look@/]
58-- @'declare' x >> 'look' == 'fmap' (<> x) 'look' <* 'declare' x@
59-- for every @x@
60--
61-- [/@look@ as left identity/]
62-- @'look' >> m == m@
63-- for every @m@
64class (Applicative m, Monad m) => MonadDeclare d m | m -> d where
65 -- | @'declare' x@ is an action that produces the output @x@.
66 declare :: d -> m ()
67 -- | @'look'@ is an action that returns all the output so far.
68 look :: m d
70instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
71 declare d = DeclareT (\_ -> return (d, ()))
72 look = DeclareT (\d -> return (mempty, d))
74-- | Retrieve a function of all the output so far.
75looks :: MonadDeclare d m => (d -> a) -> m a
76looks f = f <$> look
78-- | Evaluate @'DeclareT' d m a@ computation,
79-- ignoring new output @d@.
80evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
81evalDeclareT (DeclareT f) d = snd `liftM` f d
83-- | Execute @'DeclateT' d m a@ computation,
84-- ignoring result and only producing new output @d@.
85execDeclareT :: Monad m => DeclareT d m a -> d -> m d
86execDeclareT (DeclareT f) d = fst `liftM` f d
88-- | Evaluate @'DeclareT' d m a@ computation,
89-- starting with empty output history.
90undeclareT :: (Monad m, Monoid d) => DeclareT d m a -> m a
91undeclareT = flip evalDeclareT mempty
93-- | A declare monad parametrized by @d@ — the output to accumulate (declarations).
94--
95-- This monad is similar to both state and writer monads.
96-- Thus it can be seen as
97--
98-- * a restricted append-only version of a state monad or
99--
100-- * a writer monad with the extra ability to read all previous output.
101type Declare d = DeclareT d Identity
103-- | Run @'Declare' d a@ computation with output history @d@,
104-- producing result @a@ and new output @d@.
105runDeclare :: Declare d a -> d -> (d, a)
106runDeclare m = runIdentity . runDeclareT m
108-- | Evaluate @'Declare' d a@ computation, ignoring output @d@.
109evalDeclare :: Declare d a -> d -> a
110evalDeclare m = runIdentity . evalDeclareT m
112-- | Execute @'Declate' d a@ computation, ignoring result and only
113-- producing output @d@.
114execDeclare :: Declare d a -> d -> d
115execDeclare m = runIdentity . execDeclareT m
117-- | Evaluate @'DeclareT' d m a@ computation,
118-- starting with empty output history.
119undeclare :: Monoid d => Declare d a -> a
120undeclare = runIdentity . undeclareT