blob: 8a9751e3061e110cd4d53373362b8ca4d1608373 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -flate-specialise -O2 #-}
module Main (main) where
import qualified Control.Monad.State.Strict as S
import Data.Foldable
import Data.Functor.Identity
import Data.Kind
import Data.Monoid
import Data.Tuple
main :: IO ()
main = print $ badCore 100
badCore :: Int -> Int
badCore n = getSum $ fst $ run $ runState mempty $ for_ [0..n] $ \i -> modify (<> Sum i)
data Union (r :: [Type -> Type]) a where
Union :: e a -> Union '[e] a
decomp :: Union (e ': r) a -> e a
decomp (Union a) = a
{-# INLINE decomp #-}
absurdU :: Union '[] a -> b
absurdU = absurdU
newtype Semantic r a = Semantic
{ runSemantic
:: forall m
. Monad m
=> (forall x. Union r x -> m x)
-> m a
}
instance Functor (Semantic f) where
fmap f (Semantic m) = Semantic $ \k -> fmap f $ m k
{-# INLINE fmap #-}
instance Applicative (Semantic f) where
pure a = Semantic $ const $ pure a
{-# INLINE pure #-}
Semantic f <*> Semantic a = Semantic $ \k -> f k <*> a k
{-# INLINE (<*>) #-}
instance Monad (Semantic f) where
return = pure
{-# INLINE return #-}
Semantic ma >>= f = Semantic $ \k -> do
z <- ma k
runSemantic (f z) k
{-# INLINE (>>=) #-}
data State s a
= Get (s -> a)
| Put s a
deriving Functor
get :: Semantic '[State s] s
get = Semantic $ \k -> k $ Union $ Get id
{-# INLINE get #-}
put :: s -> Semantic '[State s] ()
put !s = Semantic $ \k -> k $ Union $! Put s ()
{-# INLINE put #-}
modify :: (s -> s) -> Semantic '[State s] ()
modify f = do
!s <- get
put $! f s
{-# INLINE modify #-}
runState :: s -> Semantic (State s ': r) a -> Semantic r (s, a)
runState = interpretInStateT $ \case
Get k -> fmap k S.get
Put s k -> S.put s >> pure k
{-# INLINE[3] runState #-}
run :: Semantic '[] a -> a
run (Semantic m) = runIdentity $ m absurdU
{-# INLINE run #-}
interpretInStateT
:: (forall x. e x -> S.StateT s (Semantic r) x)
-> s
-> Semantic (e ': r) a
-> Semantic r (s, a)
interpretInStateT f s (Semantic m) = Semantic $ \k ->
fmap swap $ flip S.runStateT s $ m $ \u ->
S.mapStateT (\z -> runSemantic z k) $ f $ decomp u
{-# INLINE interpretInStateT #-}
|
