dbc52c4 · effects-benchmarks

.gitignore+1

compare with master

unifiedsplit

@@ -1,4 +1,5 @@

1.stack-work

2.DS_Store

3core-html/

4+dist

4dist-newstyle/

5dist-newstyle/

effects-benchmarks.cabal+3−6

@@ -13,7 +13,7 @@ extra-source-files: README.md

13

14common shared

15 default-language: Haskell2010

16− ghc-options: -Wall -Werror -O2

16+ ghc-options: -Wall -Werror -O2 -flate-specialise

17 build-depends: base >= 4.7 && < 5

18

19library benchmark-signatures

@@ -54,7 +54,7 @@ library instances-for-fused-effects

54 exposed-modules: Fused.Stateful

55 , Fused.StatefulExcept

56 , Fused.HTTP

57− build-depends: fused-effects >= 0.4.0.0

57+ build-depends: fused-effects >= 0.5

58

59library instances-for-freer-simple

60 import: shared

@@ -67,18 +67,15 @@ library instances-for-freer-simple

67library instances-for-polysemy

68 import: shared

69 hs-source-dirs: instances

70− ghc-options: -fplugin=Polysemy.Plugin

71 exposed-modules: Poly.Stateful

70 exposed-modules: Poly.Stateful

72 , Poly.StatefulExcept

71 , Poly.StatefulExcept

73 , Poly.HTTP

72 , Poly.HTTP

74− build-depends: polysemy ^>= 0.2.1

73+ build-depends: polysemy ^>= 1.2

75− , polysemy-plugin ^>= 0.2.0.0

76

74

77benchmark effects-benchmarks

75benchmark effects-benchmarks

78 import: shared

76 import: shared

79 type: exitcode-stdio-1.0

77 type: exitcode-stdio-1.0

80 hs-source-dirs: src

78 hs-source-dirs: src

81− ghc-options: -fplugin=Polysemy.Plugin

82 build-depends: benchmark-signatures

79 build-depends: benchmark-signatures

83 , instances-for-mtl

80 , instances-for-mtl

84 , instances-for-fused-effects

81 , instances-for-fused-effects

instances/Fused/HTTP.hs+11−19

@@ -1,31 +1,23 @@

1+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DeriveGeneric, DerivingStrategies, FlexibleInstances, GeneralizedNewtypeDeriving,

1−{-# LANGUAGE TypeOperators, FlexibleInstances, KindSignatures, MultiParamTypeClasses, DeriveFunctor, UndecidableInstances, GeneralizedNewtypeDeriving #-}

2+ KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}

2

3

3module Fused.HTTP where

4module Fused.HTTP where

4

5

5import Control.Effect

6import Control.Effect

6−import Control.Effect.Sum

7import Control.Effect.Carrier

8−import Data.Coerce

9import Control.Monad.IO.Class

8import Control.Monad.IO.Class

9+import GHC.Generics (Generic1)

10

11newtype HttpC m a = HttpC { runHttpC :: m a }

12− deriving (Applicative, Functor, Monad, MonadIO)

12+ deriving newtype (Applicative, Functor, Monad, MonadIO)

13

14data HTTP (m :: * -> *) k

15− = Open String k

15+ = Open String (m k)

16− | Close k

16+ | Close (m k)

17− | Post String (String -> k)

17+ | Post String (String -> m k)

18− | HGet (String -> k)

18+ | HGet (String -> m k)

19− deriving Functor

19+ deriving stock (Functor, Generic1)

20−

20+ deriving anyclass (HFunctor, Effect)

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

21

30open' :: String -> HttpM ()

22open' :: String -> HttpM ()

31open' s = send (Open s (pure ()))

23open' s = send (Open s (pure ()))

@@ -46,7 +38,7 @@ instance (Effect sig, Carrier sig m) => Carrier (HTTP :+: sig) (HttpC m) where

46 Open _ k -> k

38 Open _ k -> k

47 Close k -> k

39 Close k -> k

48 Post s k -> k ("posted " <> s)

40 Post s k -> k ("posted " <> s)

49− HGet k -> k "lmao"

41+ HGet k -> k "lmao"

50 eff (R other) = HttpC (eff (handleCoercible other))

42 eff (R other) = HttpC (eff (handleCoercible other))

51

43

52runHttp :: HttpM a -> IO a

44runHttp :: HttpM a -> IO a

instances/Poly/HTTP.hs+3−3

@@ -1,10 +1,10 @@

1−{-# LANGUAGE DataKinds, TemplateHaskell, KindSignatures, GADTs, FlexibleContexts, TypeOperators, LambdaCase #-}

1+{-# LANGUAGE ScopedTypeVariables, DataKinds, TemplateHaskell, KindSignatures, GADTs, FlexibleContexts, TypeOperators, LambdaCase #-}

2

3module Poly.HTTP where

4

5import Polysemy

6

7−type HttpM = Sem '[Http, Lift IO]

7+type HttpM = Sem '[Http, Final IO]

8

9data Http (m :: * -> *) a where

10 HOpen :: String -> Http m ()

@@ -34,4 +34,4 @@ runHttp' = interpret $ \case

34 HGet -> pure "contents"

35

36runHttp :: HttpM a -> IO a

37−runHttp = runM . runHttp'

37+runHttp = runFinal . runHttp'