Skip to content

Instantly share code, notes, and snippets.

@bgamari

bgamari/test0-main.core.hs

Last active August 29, 2015 14:23
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save bgamari/026e3670cd6a50a07790 to your computer and use it in GitHub Desktop.
Save bgamari/026e3670cd6a50a07790 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
test0-main.core.hs
a_s2CV :: State# RealWorld -> (# State# RealWorld, () #)
a_s2CV =
\ (s_X2kt :: State# RealWorld) ->
letrec {
a_s2E2
:: [StateT Int IO Int]
-> forall r_ao0.
Int
-> State# RealWorld
-> (# State# RealWorld, ([Int] -> Int -> r_ao0) -> r_ao0 #)
a_s2E2 =
\ (ds_X2ip :: [StateT Int IO Int])
(@ r_ao0)
(eta_B2 :: Int)
(eta_B1 :: State# RealWorld) ->
case ds_X2ip of _ {
[] ->
(# eta_B1,
\ (f_aKp :: [Int] -> Int -> r_ao0) -> f_aKp ([] @ Int) eta_B2 #);
: y_a2h5 ys_a2h6 ->
((a_s2if
@ Int
@ IO
GHC.Base.$fMonadIO
@ [Int]
@ [Int]
((\ (@ r_Xpy) (eta_X1A :: Int) (eta_X2 :: State# RealWorld) ->
case (((y_a2h5
`cast` (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <Int>_N
:: StateT Int IO Int
~R# (forall r_ao0.
Int -> IO ((Int -> Int -> r_ao0) -> r_ao0))))
@ (IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy)) eta_X1A)
`cast` (NTCo:IO[0]
<(Int
-> Int -> IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy))
-> IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy)>_R
:: IO
((Int
-> Int
-> IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy))
-> IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy))
~R# (State# RealWorld
-> (# State# RealWorld,
(Int
-> Int
-> IO
((([Int] -> [Int]) -> Int -> r_Xpy)
-> r_Xpy))
-> IO
((([Int] -> [Int]) -> Int -> r_Xpy)
-> r_Xpy) #))))
eta_X2
of _ { (# ipv_a2i3, ipv1_a2i4 #) ->
((ipv1_a2i4
((\ (x_aKu :: Int) (s'_aKv :: Int) (eta_X1I :: State# RealWorld) ->
let {
x_XN9 :: [Int] -> [Int]
x_XN9 = : @ Int x_aKu } in
(# eta_X1I,
\ (f_aKp :: ([Int] -> [Int]) -> Int -> r_Xpy) ->
f_aKp x_XN9 s'_aKv #))
`cast` (<Int>_R
-> <Int>_R
-> Sym
(NTCo:IO[0] <(([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy>_R)
:: (Int
-> Int
-> State# RealWorld
-> (# State# RealWorld,
(([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy #))
~R# (Int
-> Int
-> IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy)))))
`cast` (NTCo:IO[0] <(([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy>_R
:: IO ((([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy)
~R# (State# RealWorld
-> (# State# RealWorld,
(([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy #))))
ipv_a2i3
})
`cast` ((forall r_Xpy.
<Int>_R
-> Sym
(NTCo:IO[0] <(([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy>_R))
; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int] -> [Int]>_N)
:: (forall r_Xpy.
Int
-> State# RealWorld
-> (# State# RealWorld,
(([Int] -> [Int]) -> Int -> r_Xpy) -> r_Xpy #))
~R# StateT Int IO ([Int] -> [Int])))
((a_s2E2
(ys_a2h6
`cast` (Sym
(Nth:0
(<[StateT Int IO Int]>_R
-> (forall r_Xpy.
<Int>_R
-> Sym (NTCo:IO[0] <([Int] -> Int -> r_Xpy) -> r_Xpy>_R))
; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int]>_N)))
:: [StateT Int IO Int] ~R# [StateT Int IO Int])))
`cast` (Nth:1
(<[StateT Int IO Int]>_R
-> (forall r_Xpy.
<Int>_R -> Sym (NTCo:IO[0] <([Int] -> Int -> r_Xpy) -> r_Xpy>_R))
; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int]>_N))
:: (forall r_Xpy.
Int
-> State# RealWorld
-> (# State# RealWorld, ([Int] -> Int -> r_Xpy) -> r_Xpy #))
~R# StateT Int IO [Int]))
@ r_ao0
eta_B2)
`cast` (NTCo:IO[0] <([Int] -> Int -> r_ao0) -> r_ao0>_R
:: IO (([Int] -> Int -> r_ao0) -> r_ao0)
~R# (State# RealWorld
-> (# State# RealWorld, ([Int] -> Int -> r_ao0) -> r_ao0 #))))
eta_B1
}; } in
case ((((a_s2E2
((build
@ (StateT Int IO Int)
(\ (@ b_a26J)
(c_a26K :: StateT Int IO Int -> b_a26J -> b_a26J)
(nil_a26L :: b_a26J) ->
repeatFB
@ (StateT Int IO Int)
@ (Int -> b_a26J)
(takeFB @ (StateT Int IO Int) @ b_a26J c_a26K nil_a26L)
((\ (@ r_XqO) (eta_X2Q :: Int) (eta_X2T :: State# RealWorld) ->
case eta_X2Q of _ { I# x_a28l ->
let {
ipv_s2gq :: Int#
ipv_s2gq = +# x_a28l 1# } in
let {
s_Xxf :: Int
s_Xxf = I# ipv_s2gq } in
(# eta_X2T,
\ (f_ax9 :: Int -> Int -> r_XqO) -> f_ax9 s_Xxf s_Xxf #)
})
`cast` ((forall r_XqO.
<Int>_R -> Sym (NTCo:IO[0] <(Int -> Int -> r_XqO) -> r_XqO>_R))
; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <Int>_N)
:: (forall r_XqO.
Int
-> State# RealWorld
-> (# State# RealWorld, (Int -> Int -> r_XqO) -> r_XqO #))
~R# StateT Int IO Int))
(I# 1000#)))
`cast` (Sym
(Nth:0
(<[StateT Int IO Int]>_R
-> (forall r_ao0.
<Int>_R -> Sym (NTCo:IO[0] <([Int] -> Int -> r_ao0) -> r_ao0>_R))
; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int]>_N)))
:: [StateT Int IO Int] ~R# [StateT Int IO Int])))
`cast` (Nth:1
(<[StateT Int IO Int]>_R
-> (forall r_ao0.
<Int>_R -> Sym (NTCo:IO[0] <([Int] -> Int -> r_ao0) -> r_ao0>_R))
; Sym (Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int]>_N))
; Cont8.NTCo:StateT[0] <Int>_N <IO>_R <[Int]>_N
:: (forall r_ao0.
Int
-> State# RealWorld
-> (# State# RealWorld, ([Int] -> Int -> r_ao0) -> r_ao0 #))
~R# (forall r_ao0. Int -> IO (([Int] -> Int -> r_ao0) -> r_ao0))))
@ ([Int], Int) (I# 0#))
`cast` (NTCo:IO[0]
<([Int] -> Int -> ([Int], Int)) -> ([Int], Int)>_R
:: IO (([Int] -> Int -> ([Int], Int)) -> ([Int], Int))
~R# (State# RealWorld
-> (# State# RealWorld,
([Int] -> Int -> ([Int], Int)) -> ([Int], Int) #))))
s_X2kt
of _ { (# ipv_a2i3, ipv1_a2i4 #) ->
hPutStr2
stdout
(case ipv1_a2i4 ((,) @ [Int] @ Int) of _ { (x_a27I, ds1_a27J) ->
showList__ @ Int shows7 x_a27I ([] @ Char)
})
True
ipv_a2i3
}
main :: IO ()
main =
a_s2CV
`cast` (Sym (NTCo:IO[0] <()>_R)
:: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ())
Raw
test0.hs
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module Cont8 (main) where
import Prelude
liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r
liftM f m1 = do { x1 <- m1; return (f x1) }
ap :: (Monad m) => m (a -> b) -> m a -> m b
ap m1 m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) }
replicateM :: (Monad m) => Int -> m a -> m [a]
replicateM n x = sequence (replicate n x)
modify :: Monad m => (s -> s) -> StateT s m ()
modify f = get >>= put . f
newtype StateT s m a = StateT { getStateTFunc
:: forall r . s -> m ((a -> s -> r) -> r)}
instance Monad m => Functor (StateT s m) where
fmap = liftM
instance Monad m => Applicative (StateT s m) where
pure = return
(<*>) = ap
instance Monad m => Monad (StateT s m) where
return x = StateT $ \s -> return $ \f -> f x s
StateT f >>= g = StateT $ \s -> do
useX <- f s
useX $ \x s' -> getStateTFunc (g x) s'
runStateT :: Monad m => StateT s m a -> s -> m (a, s)
runStateT f s = do
useXS <- getStateTFunc f s
return $ useXS $ \x s' -> (x,s')
get :: Monad m => StateT s m s
get = StateT $ \s -> return $ \f -> f s s
put :: Monad m => s -> StateT s m ()
put s = s `seq` StateT $ \_ -> return $ \f -> f () s
-- benchmark
incrementLevel0 :: LargeState Int
incrementLevel0 = do
modify inc
get
inc :: Int -> Int
inc n = n + 1
{-# INLINE inc #-}
type LargeState = StateT Int IO
runLargeState :: LargeState a -> IO a
runLargeState s = do
let s0 = liftM fst $ runStateT s 0
--let s1 = liftM fst $ runStateT s0 0
--let s2 = liftM fst $ runStateT s1 0
--let s3 = liftM fst $ runStateT s2 0
--let s4 = liftM fst $ runStateT s3 0
--let s5 = liftM fst $ runStateT s4 0
s0
main :: IO ()
main = do
s <- runLargeState $ replicateM 1000 incrementLevel0
putStrLn $ show s
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment