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