git.iko.soy/effects-benchmarks
on master help sign in
whoops forgot a ton of instances.
56a3e0cPatrick Thomson
instances/Freer/HTTP.hsnew file+36
compare with master
unifiedsplit
@@ -0,0 +1,36 @@
1+{-# LANGUAGE DataKinds, TypeOperators, GADTs #-}
2+
3+module Freer.HTTP where
4+
5+import Control.Monad.Freer
6+
7+type HttpM = Eff '[HTTP, IO]
8+
9+data HTTP a where
10+ Open :: String -> HTTP ()
11+ Close :: HTTP ()
12+ Post :: String -> HTTP String
13+ HGet :: HTTP String
14+
15+open' :: String -> HttpM ()
16+open' = send . Open
17+
18+close' :: HttpM ()
19+close' = send Close
20+
21+post' :: String -> HttpM String
22+post' = send . Post
23+
24+get' :: HttpM String
25+get' = send HGet
26+
27+doHttp :: Eff (HTTP ': e) b -> Eff e b
28+doHttp = interpret
29+ (\x -> case x of
30+ Open _ -> pure ()
31+ Close -> pure ()
32+ Post a -> pure a
33+ HGet -> pure "gotten")
34+
35+runHttp :: HttpM a -> IO a
36+runHttp = runM . doHttp
instances/Fused/HTTP.hsnew file+53
@@ -0,0 +1,53 @@
1+{-# LANGUAGE TypeOperators, FlexibleInstances, KindSignatures, MultiParamTypeClasses, DeriveFunctor, UndecidableInstances, GeneralizedNewtypeDeriving #-}
2+
3+module Fused.HTTP where
4+
5+import Control.Effect
6+import Control.Effect.Sum
7+import Control.Effect.Carrier
8+import Data.Coerce
9+import Control.Monad.IO.Class
10+
11+newtype HttpC m a = HttpC { runHttpC :: m a }
12+ deriving (Applicative, Functor, Monad, MonadIO)
13+
14+data HTTP (m :: * -> *) k
15+ = Open String k
16+ | Close k
17+ | Post String (String -> k)
18+ | HGet (String -> k)
19+ deriving Functor
20+
21+instance Effect HTTP where
22+ handle state handler (Open s k) = Open s (handler . (<$ state) $ k)
23+ handle state handler (Close k) = Close (handler . (<$ state) $ k)
24+ handle state handler (Post s k) = Post s (handler . (<$ state) . k)
25+ handle state handler (HGet k) = HGet (handler . (<$ state) . k)
26+
27+instance HFunctor HTTP where
28+ hmap _ = coerce
29+
30+open' :: String -> HttpM ()
31+open' s = send (Open s (pure ()))
32+
33+close' :: HttpM ()
34+close' = send (Close (pure ()))
35+
36+post' :: String -> HttpM String
37+post' s = send (Post s pure)
38+
39+get' :: HttpM String
40+get' = send (HGet pure)
41+
42+type HttpM = HttpC (LiftC IO)
43+
44+instance (Effect sig, Carrier sig m) => Carrier (HTTP :+: sig) (HttpC m) where
45+ eff (L act) = case act of
46+ Open _ k -> k
47+ Close k -> k
48+ Post s k -> k ("posted " <> s)
49+ HGet k -> k "lmao"
50+ eff (R other) = HttpC (eff (handleCoercible other))
51+
52+runHttp :: HttpM a -> IO a
53+runHttp = runM . runHttpC
instances/MTL/DeepHTTP.hsnew file+47
@@ -0,0 +1,47 @@
1+{-# LANGUAGE GADTs, LambdaCase #-}
2+
3+module MTL.DeepHTTP where
4+
5+import Control.Applicative
6+import Control.Monad
7+
8+data HttpM a where
9+ Pure :: a -> HttpM a
10+ Lift :: IO a -> HttpM a
11+ Then :: HttpM a -> (a -> HttpM b) -> HttpM b
12+ Open :: String -> HttpM ()
13+ Shut :: HttpM ()
14+ Post :: String -> HttpM String
15+ HGet :: HttpM String
16+
17+instance Functor HttpM where
18+ fmap = liftA
19+
20+instance Applicative HttpM where
21+ pure = Pure
22+ (<*>) = ap
23+
24+instance Monad HttpM where
25+ (>>=) = Then
26+
27+get' :: HttpM String
28+get' = HGet
29+
30+post' :: String -> HttpM String
31+post' = Post
32+
33+close' :: HttpM ()
34+close' = Shut
35+
36+open' :: String -> HttpM ()
37+open' = Open
38+
39+runHttp :: HttpM a -> IO a
40+runHttp = \case
41+ Pure x -> pure x
42+ Lift m -> m
43+ Then x f -> runHttp x >>= runHttp . f
44+ Open _ -> pure ()
45+ Shut -> pure ()
46+ Post s -> pure ("posted " <> s)
47+ HGet -> pure "lmap"
instances/Shallow/HTTP.hsnew file+18
@@ -0,0 +1,18 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+
3+module Shallow.HTTP where
4+
5+newtype HttpM a = HttpM { runHttp :: IO a}
6+ deriving (Applicative, Functor, Monad)
7+
8+get' :: HttpM String
9+get' = pure "lmao"
10+
11+post' :: String -> HttpM String
12+post' s = pure ("posted " <> s)
13+
14+close' :: HttpM ()
15+close' = pure ()
16+
17+open' :: String -> HttpM ()
18+open' _ = pure ()
instances/Shallow/Stateful.hsnew file+24
@@ -0,0 +1,24 @@
1+module Shallow.Stateful where
2+
3+import Control.Monad
4+
5+newtype StateM a = StateM { unStateM :: Int -> (Int, a) }
6+
7+instance Functor StateM where
8+ fmap f (StateM a) = StateM (\n -> fmap f (a n))
9+
10+instance Applicative StateM where
11+ pure x = StateM (\n -> (n, x))
12+ (<*>) = ap
13+
14+instance Monad StateM where
15+ StateM a >>= f = StateM $ \n -> let (x, y) = a n in unStateM (f y) x
16+
17+get :: StateM Int
18+get = StateM $ \n -> (n, n)
19+
20+put :: Int -> StateM ()
21+put x = StateM (\_ -> (x, ()))
22+
23+runStateful :: Int -> StateM a -> (Int, a)
24+runStateful n (StateM f) = f $! n
instances/Shallow/StatefulExcept.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+
3+module Shallow.StatefulExcept where
4+
5+import Control.Monad
6+
7+newtype StateM a = StateM { unStateM :: Int -> Either String (Int, a) }
8+
9+instance Functor StateM where
10+ fmap f (StateM a) = StateM (\n -> fmap (fmap f) (a n))
11+
12+instance Applicative StateM where
13+ pure x = StateM (\n -> Right (n, x))
14+ (<*>) = ap
15+
16+instance Monad StateM where
17+ (StateM a) >>= f = StateM (\n -> case a n of
18+ Left s -> Left s
19+ Right (n', x) -> unStateM (f x) n')
20+
21+get :: StateM Int
22+get = StateM (\n -> Right (n, n))
23+
24+put :: Int -> StateM ()
25+put x = StateM (\_ -> Right (x, ()))
26+
27+throw :: String -> StateM a
28+throw s = StateM (\_ -> Left s)
29+
30+runStatefulExcept :: Int -> StateM a -> Either String (Int, a)
31+runStatefulExcept n (StateM f) = f $! n
src/Bench/Countdown/StateExcept.hsdeleted−2
@@ -1,2 +0,0 @@
1−module Bench.Countdown.StateExcept where
2−
src/Bench/HTTP.hsnew file+11
@@ -0,0 +1,11 @@
1+module Bench.HTTP where
2+
3+import Bench.Signature.HTTP
4+import Control.Monad
5+
6+doHTTP :: Int -> IO Int
7+doHTTP n = runHttp $ do
8+ open' "cats"
9+ replicateM_ n (get' *> post' "cats")
10+ close'
11+ pure n
src/Bench/Signature/HTTP.hsignew file+19
@@ -0,0 +1,19 @@
1+signature Bench.Signature.HTTP
2+ ( HttpM
3+ , open'
4+ , close'
5+ , post'
6+ , get'
7+ , runHttp
8+ ) where
9+
10+data HttpM a
11+
12+instance Applicative HttpM
13+instance Monad HttpM
14+
15+open' :: String -> HttpM ()
16+get' :: HttpM String
17+post' :: String -> HttpM String
18+close' :: HttpM ()
19+runHttp :: HttpM a -> IO a