Skip to content

Instantly share code, notes, and snippets.

@isovector

isovector/MVP.dump-simpl

Created March 21, 2019 19:57
Show Gist options
  • Save isovector/6b443715a8fab2812daf28905558c17e to your computer and use it in GitHub Desktop.
Save isovector/6b443715a8fab2812daf28905558c17e to your computer and use it in GitHub Desktop.
Download ZIP
Raw
MVP.dump-simpl
==================== Tidy Core ====================
Result size of Tidy Core
= {terms: 627, types: 1,687, coercions: 398, joins: 1/6}
-- RHS size: {terms: 5, types: 21, coercions: 11, joins: 0/0}
$WUnion
$WUnion = \ @ e_XHpZ @ a_aHpZ dt_aHuO -> Union @~ <Co:11> dt_aHuO
-- RHS size: {terms: 16, types: 33, coercions: 3, joins: 0/0}
$cfmap_rInp
$cfmap_rInp
= \ @ f_aHUn
@ a_aHUr
@ b_aHUs
f1_aHqb
ds_dHY3
@ m_aHUz
$dMonad_aHUA
eta_B1 ->
fmap
($p1Applicative ($p1Monad $dMonad_aHUA))
f1_aHqb
((ds_dHY3 `cast` <Co:3>) $dMonad_aHUA eta_B1)
-- RHS size: {terms: 1, types: 0, coercions: 23, joins: 0/0}
$fFunctorSemantic_$cfmap
$fFunctorSemantic_$cfmap = $cfmap_rInp `cast` <Co:23>
-- RHS size: {terms: 17, types: 33, coercions: 3, joins: 0/0}
$fApplicativeSemantic4
$fApplicativeSemantic4
= \ @ f_XHVo
@ a_aHUV
@ b_aHUW
x_aeaI
eta_B3
@ m_aHpU
eta1_B2
eta2_B1 ->
fmap
($p1Applicative ($p1Monad eta1_B2))
(\ _ -> x_aeaI)
((eta_B3 `cast` <Co:3>) eta1_B2 eta2_B1)
-- RHS size: {terms: 19, types: 39, coercions: 3, joins: 0/0}
$fApplicativeSemantic3
$fApplicativeSemantic3
= \ @ f_XHU0
@ a_aHU2
@ b_aHU3
a1_afCT
a2_afCU
@ m_aHpU
eta_B2
eta1_B1 ->
<*>
($p1Monad eta_B2)
($fApplicativeSemantic4 breakpoint a1_afCT eta_B2 eta1_B1)
((a2_afCU `cast` <Co:3>) eta_B2 eta1_B1)
-- RHS size: {terms: 4, types: 9, coercions: 16, joins: 0/0}
$fFunctorSemantic
$fFunctorSemantic
= \ @ f_XHVn ->
C:Functor
$fFunctorSemantic_$cfmap ($fApplicativeSemantic4 `cast` <Co:16>)
-- RHS size: {terms: 17, types: 35, coercions: 7, joins: 0/0}
$c<*>_rInr
$c<*>_rInr
= \ @ f_aHSK
@ a_aHTf
@ b_aHTg
ds_dHXV
ds1_dHXW
@ m_aHTn
$dMonad_aHTo
eta_B1 ->
<*>
($p1Monad $dMonad_aHTo)
((ds_dHXV `cast` <Co:4>) $dMonad_aHTo eta_B1)
((ds1_dHXW `cast` <Co:3>) $dMonad_aHTo eta_B1)
-- RHS size: {terms: 1, types: 0, coercions: 25, joins: 0/0}
$fApplicativeSemantic_$c<*>
$fApplicativeSemantic_$c<*> = $c<*>_rInr `cast` <Co:25>
-- RHS size: {terms: 12, types: 26, coercions: 0, joins: 0/1}
$cpure_rIns
$cpure_rIns
= \ @ f_XHTT @ a_aHSS a1_aHq6 @ m_aHSZ $dMonad_aHT0 ->
let {
ds_sI2g
ds_sI2g = pure ($p1Monad $dMonad_aHT0) a1_aHq6 } in
\ _ -> ds_sI2g
-- RHS size: {terms: 1, types: 0, coercions: 15, joins: 0/0}
$fApplicativeSemantic_$cpure
$fApplicativeSemantic_$cpure = $cpure_rIns `cast` <Co:15>
-- RHS size: {terms: 24, types: 45, coercions: 6, joins: 0/0}
$fApplicativeSemantic2
$fApplicativeSemantic2
= \ @ f_XHU1
@ a_aHTP
@ b_aHTQ
@ c_aHTR
f1_afCM
x_afCN
eta_X1G
@ m_aHpU
eta1_B2
eta2_B1 ->
<*>
($p1Monad eta1_B2)
(fmap
($p1Applicative ($p1Monad eta1_B2))
f1_afCM
((x_afCN `cast` <Co:3>) eta1_B2 eta2_B1))
((eta_X1G `cast` <Co:3>) eta1_B2 eta2_B1)
-- RHS size: {terms: 5, types: 15, coercions: 0, joins: 0/0}
$fApplicativeSemantic1
$fApplicativeSemantic1
= \ @ b_aHUe @ a_aHUd @ f_XHTZ -> $fApplicativeSemantic2 const
-- RHS size: {terms: 10, types: 19, coercions: 61, joins: 0/0}
$fApplicativeSemantic
$fApplicativeSemantic
= \ @ f_XHTY ->
C:Applicative
$fFunctorSemantic
$fApplicativeSemantic_$cpure
$fApplicativeSemantic_$c<*>
($fApplicativeSemantic2 `cast` <Co:25>)
($fApplicativeSemantic3 `cast` <Co:18>)
((\ @ a_aHUd @ b_aHUe -> $fApplicativeSemantic1) `cast` <Co:18>)
-- RHS size: {terms: 15, types: 22, coercions: 0, joins: 0/0}
$fFunctorState_$c<$
$fFunctorState_$c<$
= \ @ s_aHQ3 @ a_aHQJ @ b_aHQK z2_aHxq ds_dHXJ ->
case ds_dHXJ of {
Get a1_aHxr -> Get (\ _ -> z2_aHxq);
Put a1_aHxx a2_aHxy -> Put a1_aHxx z2_aHxq
}
-- RHS size: {terms: 18, types: 23, coercions: 0, joins: 0/0}
$fFunctorState_$cfmap
$fFunctorState_$cfmap
= \ @ s_aHQ3 @ a_aHQ7 @ b_aHQ8 f_aHxh ds_dHXI ->
case ds_dHXI of {
Get a1_aHxi -> Get (\ b3_aHxk -> f_aHxh (a1_aHxi b3_aHxk));
Put a1_aHxn a2_aHxo -> Put a1_aHxn (f_aHxh a2_aHxo)
}
-- RHS size: {terms: 4, types: 6, coercions: 0, joins: 0/0}
$fFunctorState
$fFunctorState
= \ @ s_aHQ3 -> C:Functor $fFunctorState_$cfmap $fFunctorState_$c<$
-- RHS size: {terms: 9, types: 24, coercions: 3, joins: 0/0}
runSemantic
runSemantic
= \ @ r_aHw2 @ a_aHw3 dk_aHWh @ m_aHw6 $dMonad_aHw7 ds_dHXG ->
(dk_aHWh `cast` <Co:3>) $dMonad_aHw7 ds_dHXG
-- RHS size: {terms: 28, types: 68, coercions: 6, joins: 0/1}
$w$c>>=_rInt
$w$c>>=_rInt
= \ @ f_sIen
@ a_sIeo
@ b_sIep
w_sIeq
w1_sIer
@ m_sIes
ww_sIex
ww1_sIey
ww2_sIez
ww3_sIeA
ww4_sIeB
w2_sIeu ->
let {
$dMonad_aHRP
$dMonad_aHRP
= C:Monad ww_sIex ww1_sIey ww2_sIez ww3_sIeA ww4_sIeB } in
ww1_sIey
((w_sIeq `cast` <Co:3>) $dMonad_aHRP w2_sIeu)
(\ z2_aHq4 ->
((w1_sIer z2_aHq4) `cast` <Co:3>) $dMonad_aHRP w2_sIeu)
-- RHS size: {terms: 20, types: 68, coercions: 0, joins: 0/0}
$c>>=_rInu
$c>>=_rInu
= \ @ f_sIen
@ a_sIeo
@ b_sIep
w_sIeq
w1_sIer
@ m_sIes
w2_sIet
w3_sIeu ->
case w2_sIet of
{ C:Monad ww1_sIex ww2_sIey ww3_sIez ww4_sIeA ww5_sIeB ->
$w$c>>=_rInt
w_sIeq w1_sIer ww1_sIex ww2_sIey ww3_sIez ww4_sIeA ww5_sIeB w3_sIeu
}
-- RHS size: {terms: 1, types: 0, coercions: 25, joins: 0/0}
$fMonadSemantic_$c>>=
$fMonadSemantic_$c>>= = $c>>=_rInu `cast` <Co:25>
-- RHS size: {terms: 29, types: 69, coercions: 6, joins: 0/2}
$w$c>>_rInv
$w$c>>_rInv
= \ @ f_sIeE
@ a_sIeF
@ b_sIeG
w_sIeH
w1_sIeI
@ m_sIeJ
ww_sIeO
ww1_sIeP
ww2_sIeQ
ww3_sIeR
ww4_sIeS
w2_sIeL ->
let {
$dMonad_aHRP
$dMonad_aHRP
= C:Monad ww_sIeO ww1_sIeP ww2_sIeQ ww3_sIeR ww4_sIeS } in
let {
lvl4_sI4N
lvl4_sI4N = (w1_sIeI `cast` <Co:3>) $dMonad_aHRP w2_sIeL } in
ww1_sIeP
((w_sIeH `cast` <Co:3>) $dMonad_aHRP w2_sIeL) (\ _ -> lvl4_sI4N)
-- RHS size: {terms: 20, types: 67, coercions: 0, joins: 0/0}
$c>>_rInw
$c>>_rInw
= \ @ f_sIeE
@ a_sIeF
@ b_sIeG
w_sIeH
w1_sIeI
@ m_sIeJ
w2_sIeK
w3_sIeL ->
case w2_sIeK of
{ C:Monad ww1_sIeO ww2_sIeP ww3_sIeQ ww4_sIeR ww5_sIeS ->
$w$c>>_rInv
w_sIeH w1_sIeI ww1_sIeO ww2_sIeP ww3_sIeQ ww4_sIeR ww5_sIeS w3_sIeL
}
-- RHS size: {terms: 1, types: 0, coercions: 24, joins: 0/0}
$fMonadSemantic_$c>>
$fMonadSemantic_$c>> = $c>>_rInw `cast` <Co:24>
-- RHS size: {terms: 5, types: 13, coercions: 0, joins: 0/0}
lvl3_rInx
lvl3_rInx
= \ @ f_XHT2 @ a_aHSC eta_B1 -> errorWithoutStackTrace eta_B1
-- RHS size: {terms: 7, types: 12, coercions: 0, joins: 0/0}
$fMonadSemantic
$fMonadSemantic
= \ @ f_XHT2 ->
C:Monad
$fApplicativeSemantic
$fMonadSemantic_$c>>=
$fMonadSemantic_$c>>
$fApplicativeSemantic_$cpure
lvl3_rInx
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule4
$trModule4 = "polysemy-0.1.0.0-IzX3okgutsQ7OM1E6vzFzd"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule3
$trModule3 = TrNameS $trModule4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule2
$trModule2 = "MVP"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule1
$trModule1 = TrNameS $trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$trModule
$trModule = Module $trModule3 $trModule1
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
$krep_rIny
$krep_rIny = : krep$*Arr* []
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$krep1_rInz
$krep1_rInz = KindRepTyConApp $tc[] $krep_rIny
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$tcSemantic1
$tcSemantic1 = KindRepFun $krep1_rInz krep$*Arr*
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$krep2_rInA
$krep2_rInA = KindRepVar 1#
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
$krep3_rInB
$krep3_rInB = : $krep2_rInA []
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$krep4_rInC
$krep4_rInC = KindRepVar 0#
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$krep5_rInD
$krep5_rInD = KindRepFun $krep4_rInC $krep2_rInA
-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
$krep6_rInE
$krep6_rInE = : $krep4_rInC $krep3_rInB
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$krep7_rInF
$krep7_rInF = KindRepTyConApp $tc'[] $krep_rIny
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
$krep8_rInG
$krep8_rInG = : $krep7_rInF []
-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
$krep9_rInH
$krep9_rInH = : $krep4_rInC $krep8_rInG
-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
$krep10_rInI
$krep10_rInI = : krep$*Arr* $krep9_rInH
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$krep11_rInJ
$krep11_rInJ = KindRepTyConApp $tc': $krep10_rInI
-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
$krep12_rInK
$krep12_rInK = : $krep11_rInJ $krep3_rInB
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$krep13_rInL
$krep13_rInL = KindRepApp $krep4_rInC $krep2_rInA
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$tcUnion2
$tcUnion2 = "Union"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$tcUnion1
$tcUnion1 = TrNameS $tcUnion2
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
$tcUnion
$tcUnion
= TyCon
10183726110959571363##
6104213444856724699##
$trModule
$tcUnion1
0#
$tcSemantic1
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$krep14_rInM
$krep14_rInM = KindRepTyConApp $tcUnion $krep12_rInK
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$tc'Union1
$tc'Union1 = KindRepFun $krep13_rInL $krep14_rInM
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$tc'Union3
$tc'Union3 = "'Union"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$tc'Union2
$tc'Union2 = TrNameS $tc'Union3
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
$tc'Union
$tc'Union
= TyCon
4320940093679973584##
10369101217397518551##
$trModule
$tc'Union2
2#
$tc'Union1
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$tcSemantic3
$tcSemantic3 = "Semantic"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$tcSemantic2
$tcSemantic2 = TrNameS $tcSemantic3
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
$tcSemantic
$tcSemantic
= TyCon
15490155384137928802##
11184477515896201153##
$trModule
$tcSemantic2
0#
$tcSemantic1
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$tcState2
$tcState2 = "State"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$tcState1
$tcState1 = TrNameS $tcState2
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
$tcState
$tcState
= TyCon
9249060897526218628##
16347136684228794284##
$trModule
$tcState1
0#
krep$*->*->*
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$krep15_rInN
$krep15_rInN = KindRepTyConApp $tcState $krep6_rInE
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$krep16_rInO
$krep16_rInO = KindRepFun $krep2_rInA $krep15_rInN
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$tc'Put1
$tc'Put1 = KindRepFun $krep4_rInC $krep16_rInO
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
$tc'Get1
$tc'Get1 = KindRepFun $krep5_rInD $krep15_rInN
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$tc'Put3
$tc'Put3 = "'Put"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$tc'Put2
$tc'Put2 = TrNameS $tc'Put3
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
$tc'Put
$tc'Put
= TyCon
299127193517142447##
1986874921509217573##
$trModule
$tc'Put2
2#
$tc'Put1
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$tc'Get3
$tc'Get3 = "'Get"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$tc'Get2
$tc'Get2 = TrNameS $tc'Get3
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
$tc'Get
$tc'Get
= TyCon
7370582334777385652##
13642457196985649685##
$trModule
$tc'Get2
2#
$tc'Get1
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
badCore2
badCore2 = I# 0#
-- RHS size: {terms: 2, types: 6, coercions: 0, joins: 0/0}
badCore7
badCore7 = Get id
-- RHS size: {terms: 2, types: 18, coercions: 13, joins: 0/0}
badCore6
badCore6 = Union @~ <Co:13> badCore7
-- RHS size: {terms: 7, types: 28, coercions: 0, joins: 0/0}
badCore5
badCore5
= \ @ m_aHSZ $dMonad_aHT0 _ -> pure ($p1Monad $dMonad_aHT0) ()
-- RHS size: {terms: 2, types: 3, coercions: 0, joins: 0/0}
badCore4
badCore4 = $fMonadStateT $fMonadIdentity
-- RHS size: {terms: 17, types: 91, coercions: 17, joins: 0/0}
badCore3
badCore3
= \ @ x_aHDl u_aHue eta_X33 ->
case u_aHue of { Union @ e_aHCJ co_aHCK a_aHu0 ->
case a_aHu0 `cast` <Co:5> of {
Get k_aHu6 -> (k_aHu6 eta_X33, eta_X33) `cast` <Co:6>;
Put s_aHu7 k_aHu8 -> (k_aHu8, s_aHu7) `cast` <Co:6>
}
}
-- RHS size: {terms: 54, types: 140, coercions: 117, joins: 0/1}
$wbadCore
$wbadCore
= \ ww_sIfj ->
case ># 0# ww_sIfj of {
__DEFAULT ->
letrec {
go_sI85
go_sI85
= \ x_aI0R @ m_aHpU eta_B2 eta1_B1 ->
$fApplicativeSemantic3
((\ @ m1_aHRO $dMonad_aHRP k_aHq3 ->
>>=
$dMonad_aHRP
(k_aHq3 badCore6)
(\ z2_aHq4 ->
case z2_aHq4 `cast` <Co:2> of { I# ipv_sI06 ->
k_aHq3
(Union
@~ <Co:13> (Put ((I# (+# ipv_sI06 x_aI0R)) `cast` <Co:3>) ()))
}))
`cast` <Co:16>)
(case ==# x_aI0R ww_sIfj of {
__DEFAULT -> (go_sI85 (+# x_aI0R 1#)) `cast` <Co:16>;
1# -> badCore5 `cast` <Co:16>
})
eta_B2
eta1_B1; } in
case (((go_sI85 0# badCore4 (badCore3 `cast` <Co:25>))
`cast` <Co:5>)
(badCore2 `cast` <Co:3>))
`cast` <Co:5>
of
{ (a1_ar8l, b1_ar8m) ->
b1_ar8m
};
1# -> badCore2 `cast` <Co:13>
}
-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
badCore1
badCore1
= \ w_sIfg -> case w_sIfg of { I# ww1_sIfj -> $wbadCore ww1_sIfj }
-- RHS size: {terms: 1, types: 0, coercions: 4, joins: 0/0}
badCore
badCore = badCore1 `cast` <Co:4>
-- RHS size: {terms: 34, types: 11, coercions: 6, joins: 1/1}
goodCore1
goodCore1
= \ w_sIft ->
case w_sIft of { I# ww1_sIfw ->
case ># 0# ww1_sIfw of {
__DEFAULT ->
joinrec {
$wgo_sIfs
$wgo_sIfs w1_sIfm ww2_sIfq
= case ==# w1_sIfm ww1_sIfw of {
__DEFAULT -> jump $wgo_sIfs (+# w1_sIfm 1#) (+# ww2_sIfq w1_sIfm);
1# -> (I# (+# ww2_sIfq w1_sIfm)) `cast` <Co:3>
}; } in
jump $wgo_sIfs 0# 0#;
1# -> badCore2 `cast` <Co:3>
}
}
-- RHS size: {terms: 1, types: 0, coercions: 4, joins: 0/0}
goodCore
goodCore = goodCore1 `cast` <Co:4>
Raw
MVP.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -ddump-simpl -dsuppress-all -O2 #-}
module MVP (badCore, goodCore) where
import qualified Control.Monad.State.Strict as S
import Data.Foldable
import Data.Functor.Identity
import Data.Monoid
import Data.Tuple
goodCore :: Int -> Int
goodCore n = getSum $ snd $ flip S.runState mempty $ for_ [0..n] $ \i -> S.modify (<> Sum i)
badCore :: Int -> Int
badCore n = getSum $ fst $ run $ runState mempty $ for_ [0..n] $ \i -> modify (<> Sum i)
data Union (r :: [* -> *]) 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 #-}
___interpretInStateT___loop_breaker
:: (forall x. e x -> S.StateT s (Semantic r) x)
-> s
-> Semantic (e ': r) a
-> Semantic r (s, a)
___interpretInStateT___loop_breaker = interpretInStateT
{-# NOINLINE ___interpretInStateT___loop_breaker #-}
@isovector
Copy link
Author

Ideally goodCore and badCore would generate identical core under -O2.

They don't, as of 8.6.3.

badCore is roughly 500x slower than goodCore 👎

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment