random stuff

Friday, 23 December 2016

{-#OPTIONS--type-in-type #-}
-- This post is also available at https://github.com/effectfully/blog/blob/master/HEff.agda
-- in the case it renders incorrectly.
-- This post is a sequel of the previous post [1]. There we've seen how simple algebraic effects
-- can be modeled in a dependently typed language. This time we'll see how Idris-like
-- resource-dependent effects [2] can be defined such that the non-termination and
-- "Codensity" effects are expressible too. The reader is assumed to be familiar with Idris effects.
moduleHEffwhere-- Some prelude first.
openimportFunctionopenimportRelation.Binary.PropositionalEqualityhiding([_])openimportData.EmptyopenimportData.Unit.BaseopenimportData.Nat.BaseopenimportData.SumopenimportData.ProductasProductopenimportData.List.Basehiding([_])modulePreludewhereinfix3 _∈_ _∈₁_ _∈²_
infix4 [_]_≅_
instanceinj₁-instance:∀{AB}{{x:A}}->A⊎Binj₁-instance{{x}}=inj₁xinj₂-instance:∀{AB}{{y:B}}->A⊎Binj₂-instance{{y}}=inj₂y-- See https://lists.chalmers.se/pipermail/agda/2016/009069.html
[_]_≅_:∀{Ax₁x₂}->(B:A->Set)->Bx₁->Bx₂->Set[B]y₁≅y₂=_≡_{A =∃B}(,y₁)(,y₂)_<×>_:∀{A}->(A->Set)->(A->Set)->A->Set(B<×>C)x=Bx×Cx_∈_:∀{A}->A->ListA->Sety∈[]=⊥y∈x∷xs=y≡x⊎y∈xs-- `List₁` is defined as a function rather than a data, because this way we get
-- eta-expansion for free. I'm not sure if this is needed in the code below,
-- but it was needed when I was writing a library some time ago.
List₁:∀{A}->(A->Set)->ListA->SetList₁B[]=⊤List₁B(x∷xs)=Bx×List₁Bxshead₁:∀{A}{B:A->Set}{xxs}->List₁B(x∷xs)->Bxhead₁(y,ys)=ytail₁:∀{A}{B:A->Set}{xxs}->List₁B(x∷xs)->List₁Bxstail₁(y,ys)=ys_∈₁_:∀{Axxs}{B:A->Set}->Bx->List₁Bxs->Set_∈₁_{xs =[]}ztt=⊥_∈₁_{xs =_∷_}{B}z(y,ys)=[B]y≅z⊎z∈₁ysreplace₁:∀{A}{B:A->Set}{x}{xs:ListA}{y:Bx}{ys:List₁Bxs}->Bx->y∈₁ys->List₁Bxsreplace₁{xs =[]}{ys =tt}z()replace₁{xs =_∷_}{ys =y,ys}z(inj₁refl)=z,ysreplace₁{xs =_∷_}{ys =y,ys}z(inj₂p)=y,replace₁zp-- `x , y ∈² xs , ys` is a proof that `x` occurs at the same index in `xs` as `y` in `ys`.
_∈²_:∀{Axxs}{BC:A->Set}->Bx×Cx->List₁Bxs×List₁Cxs->Set_∈²_{xs =[]}(y₁,z₁)(tt,tt)=⊥_∈²_{xs =_∷_}{B}{C}(y₁,z₁)((y₂,ys),(z₂,zs))=[B<×>C](y₁,z₁)≅(y₂,z₂)⊎y₁,z₁∈²ys,zsto∈₁:∀{Axxs}{BC:A->Set}{y:Bx}{z:Cx}{ys:List₁Bxs}{zs:List₁Cxs}->y,z∈²ys,zs->z∈₁zsto∈₁{xs =[]}()to∈₁{xs =_∷_}(inj₁refl)=inj₁reflto∈₁{xs =_∷_}(inj₂p)=inj₂(to∈₁p)Sets:SetSets=ListSetHList:Sets->SetHList=List₁idopenPreludemoduleEffectModulewhere-- The type of effects in Idris is defined like this:
-- Effect : Type
-- Effect = (result : Type) ->
-- (input_resource : Type) ->
-- (output_resource : result -> Type) -> Type
-- We'll use a similar definition. There are two differences:
-- 1) Since resources are not necessary types,
-- `Effect` is parametrized by the type of its resources.
-- 2) `input_resource` is the first argument, because it's often a parameter of some particular
-- effect and Agda explicitly distinguishes between parameters and indices unlike Idris
-- (and hence it's often convenient to define an effect without an `input_resource`,
-- and bound `input_resource` in parameters telescope instead).
-- So the definition could be
-- Effect : Set -> Set
-- Effect R = R -> (A : Set) -> (A -> R) -> Set
-- where `R` is the type of resources of an effect, but we split the definition due to
-- the parameters-indices distinction mentioned above:
-- `Effectful` is `Effect` without `input_resource`.
Effectful:∀{R}->SetEffectful{R}=(A:Set)->(A->R)->SetEffect:Set->SetEffectR=R->Effectful{R}ResourcesTypes:SetResourcesTypes=Sets-- `Ψs : Effects Rs` is a list of effects typed over a list of resources types `Rs`.
Effects:ResourcesTypes->SetEffects=List₁Effect-- `rs : Resources Rs` is a heterogeneous list of resources of types from `Rs`.
Resources:ResourcesTypes->SetResources=HList-- A higher effect is an effect that is defined over a list of simple effects and
-- transforms resources of those effects. This notion will be motivated later.
HigherEffect:SetHigherEffect=∀{Rs}->EffectsRs->Effect(ResourcesRs)HigherEffects:SetHigherEffects=ListHigherEffectrecordHApply{Rs}(Φ:HigherEffect)(Ψs:EffectsRs)rsArs′:SetwhereconstructorhappliedfieldgetHApplied:ΦΨsrsArs′-- At first I defined this as a data type, but Agda doesn't keep track of polarity of indices
-- and thus doesn't see that `Codensity` below is strictly positive when `Unionʰᵉ` is a data.
-- The `HApply` wrapper allows to infer `Φ` from `Unionʰᵉ (Φ ∷ Φs) Ψs Rs A rs′` just like
-- with the data version.
Unionʰᵉ:HigherEffects->HigherEffectUnionʰᵉ[]ΨsrsArs′=⊥Unionʰᵉ(Φ∷Φs)ΨsrsArs′=HApplyΦΨsrsArs′⊎UnionʰᵉΦsΨsrsArs′-- "Constructors" of `Unionʰᵉ`.
patternhereʰᵉa=inj₁(happlieda)patternthereʰᵉa=inj₂a-- The union of simple effects is a higher effect.
-- This is a direct counterpart of `Unionᵉ` defined in the previous post.
dataUnionᵉ:HigherEffectwhere-- Injecting an effect into some union of effects
-- changes the resource at the position where the effect occurs (1).
hereᵉ:∀{RRsrAr′rs}{Ψ:EffectR}{Ψs:EffectsRs}->ΨrAr′->Unionᵉ(Ψ,Ψs)(r,rs)A(λx->r′x,rs)-- Injecting an effect into some union of effects
-- doesn't change the resources of all other effects.
thereᵉ:∀{RRsrArsrs′}{Ψ:EffectR}{Ψs:EffectsRs}->UnionᵉΨsrsArs′->Unionᵉ(Ψ,Ψs)(r,rs)A(λx->r,rs′x)hinj:∀{ΦΦsRsrsArs′}{Ψs:EffectsRs}->Φ∈Φs->ΦΨsrsArs′->UnionʰᵉΦsΨsrsArs′hinj{Φs =[]}()hinj{Φs =_∷_}(inj₁refl)=hereʰᵉhinj{Φs =_∷_}(inj₂p)=thereʰᵉ∘hinjp-- This is another way to express (1).
inj′:∀{RRsrAr′rs}{Ψ:EffectR}{Ψs:EffectsRs}->(p:Ψ,r∈²Ψs,rs)->ΨrAr′->UnionᵉΨsrsA(λx->replace₁(r′x)(to∈₁p))inj′{Rs =[]}()inj′{Rs =_∷_}(inj₁refl)=hereᵉinj′{Rs =_∷_}(inj₂p)=thereᵉ∘inj′p-- If an effect doesn't change its resource, then the resources of the union of effects
-- don't change as well.
inj:∀{RRsrArs}{Ψ:EffectR}{Ψs:EffectsRs}->Ψ,r∈²Ψs,rs->ΨrA(constr)->UnionᵉΨsrsA(constrs)inj{Rs =[]}()inj{Rs =_∷_}(inj₁refl)=hereᵉinj{Rs =_∷_}(inj₂p)=thereᵉ∘injpopenEffectModulemoduleIFreerModulewhereinfixl2 _>>=_ _>=>_
infixr1 _>>_
infixl6 _<$>_ _<*>_
-- `IFreer` is the indexed counterpart of `Freer` and it's an effect transformer too.
-- `IFreer` is a Hoare state monad (in the sense of [3]; [4] is relevant here too).
dataIFreer{R}(Ψ:EffectR):EffectRwherereturn:∀{Br′}y->IFreerΨ(r′y)Br′call:∀{rAr′Br′′}->ΨrAr′->(∀x->IFreerΨ(r′x)Br′′)->IFreerΨrBr′′liftᶠ:∀{RrAr′}{Ψ:EffectR}->ΨrAr′->IFreerΨrAr′liftᶠa=callareturn_>>=_:∀{RrBr′Cr′′}{Ψ:EffectR}->IFreerΨrBr′->(∀y->IFreerΨ(r′y)Cr′′)->IFreerΨrCr′′returny>>=g=gycallaf>>=g=callaλx->fx>>=g_>=>_:∀{RABr₂Cr₃}{Ψ:EffectR}{r₁:A->R}->(∀x->IFreerΨ(r₁x)Br₂)->(∀y->IFreerΨ(r₂y)Cr₃)->(∀x->IFreerΨ(r₁x)Cr₃)(f>=>g)x=fx>>=g_>>_:∀{Rr₁Br₂Cr′′}{Ψ:EffectR}->IFreerΨr₁B(constr₂)->IFreerΨr₂Cr′′->IFreerΨr₁Cr′′b>>c=b>>=constc_<$>_:∀{Rr₁Br₂C}{Ψ:EffectR}->(B->C)->IFreerΨr₁B(constr₂)->IFreerΨr₁C(constr₂)g<$>b=b>>=return∘g_<*>_:∀{Rr₁Br₂Cr₃}{Ψ:EffectR}->IFreerΨr₁(B->C)(constr₂)->IFreerΨr₂B(constr₃)->IFreerΨr₁C(constr₃)h<*>b=h>>=_<$>bhoistIFreer:∀{RrBr′}{ΨΦ:EffectR}->(∀{rAr′}->ΨrAr′->ΦrAr′)->IFreerΨrBr′->IFreerΦrBr′hoistIFreerh(returny)=returnyhoistIFreerh(callaf)=call(ha)λx->hoistIFreerh(fx)openIFreerModulemoduleEffModulewhere-- Some convenience.
patternsimpleak=call(hereʰᵉa)kpatternhigherak=call(thereʰᵉa)k-- The main definition. `HEff` describes a computation over a list of simple effects
-- and a list of higher effects that contains the `Unionᵉ` higher effect.
-- The idea is that besides performing some local effectful calls like getting
-- the state in a stateful computation, we can also perform some "big" effectful calls that
-- can change resources of several simple effects. This is why `Unionᵉ` is a higher effect --
-- it's aware of resources of simple effects and changes the row of resources
-- (by transforming one particular resource) when a simple effectful call is performed.
-- Unlike `Eff` in Idris `HEff` doesn't allow to change effects -- only their resources.
HEff:HigherEffects->HigherEffectHEffΦsΨs=IFreer(Unionʰᵉ(Unionᵉ∷Φs)Ψs)hinvoke:∀{ΦΦsRsrsArs′}{Ψs:EffectsRs}{{p:Φ∈Φs}}->ΦΨsrsArs′->HEffΦsΨsrsArs′hinvoke{{p}}=liftᶠ∘thereʰᵉ∘hinjpinvoke′:∀{ΦsRRsrAr′rs}{Ψ:EffectR}{Ψs:EffectsRs}{{p:Ψ,r∈²Ψs,rs}}->ΨrAr′->HEffΦsΨsrsA(λx->replace₁(r′x)(to∈₁p))invoke′{{p}}=liftᶠ∘hereʰᵉ∘inj′pinvoke:∀{ΦsRRsrArs}{Ψ:EffectR}{Ψs:EffectsRs}{{p:Ψ,r∈²Ψs,rs}}->ΨrA(constr)->HEffΦsΨsrsA(constrs)invoke{{p}}=liftᶠ∘hereʰᵉ∘injp-- An equivalent of `execEff` from the previous post, only for higher effects.
hexecEff:∀{ΦsRsrsBrs′rs′′}{Φ:HigherEffect}{Ψs:EffectsRs}->(∀y->HEffΦsΨs(rs′y)Brs′′)->(∀{rsArs′}->ΦΨsrsArs′->(∀x->HEffΦsΨs(rs′x)Brs′′)->HEffΦsΨsrsBrs′′)->HEff(Φ∷Φs)ΨsrsBrs′->HEffΦsΨsrsBrs′′hexecEffetaphi(returny)=etayhexecEffetaphi(simpleak)=simpleaλx->hexecEffetaphi(kx)hexecEffetaphi(higher(hereʰᵉa)k)=phiaλx->hexecEffetaphi(kx)hexecEffetaphi(higher(thereʰᵉa)k)=higheraλx->hexecEffetaphi(kx)hshift:∀{ΦsRsrsBrs′}{Φ:HigherEffect}{Ψs:EffectsRs}->HEffΦsΨsrsBrs′->HEff(Φ∷Φs)ΨsrsBrs′hshift=hoistIFreerλ{(hereʰᵉa)->hereʰᵉa;(thereʰᵉa)->thereʰᵉ(thereʰᵉa)}-- `Eff` describes a computation with no higher effects except for `Unionᵉ`.
-- I.e. it's the usual `Eff`.
Eff:HigherEffectEff=HEff[]runEff:∀{A}->EffttttA(consttt)->ArunEff(returnx)=xrunEff(simple()_)runEff(higher()_)openEffModulemoduleStateModulewhere-- The heterogeneous state effect. Its resource is of type `Set`.
-- `Get` doesn't changes the resource. `Put` changes the resource
-- from `S` (the current state) to `T` (the state after `Put` is called).
dataStateS:EffectfulwhereGet:StateSS(constS)Put:∀{T}->T->StateS⊤(constT)get:∀{ΦsRsSrs}{Ψs:EffectsRs}{{p:State,S∈²Ψs,rs}}->HEffΦsΨsrsS_get{{p}}=invoke{{p}}Getzap:∀{ΦsRsrsT}{Ψs:EffectsRs}S{{p:State,S∈²Ψs,rs}}->T->HEffΦsΨsrs⊤_zapS{{p}}=invoke′{{p}}∘Putput:∀{ΦsRsSrs}{Ψs:EffectsRs}{{p:State,S∈²Ψs,rs}}->S->HEffΦsΨsrs⊤(constrs)put{{p}}=invoke{{p}}∘Putmodify′:∀{ΦsRsSrsT}{Ψs:EffectsRs}{{p:State,S∈²Ψs,rs}}->(S->T)->HEffΦsΨsrs⊤_modify′{{p}}f=get>>=zap_{{p}}∘fmodify:∀{ΦsRsSrs}{Ψs:EffectsRs}{{p:State,S∈²Ψs,rs}}->(S->S)->HEffΦsΨsrs⊤_modifyf=get>>=put∘f-- `rs′` returns a final resource of `State` and final resources of other effects, hence
-- when the `State` effect is handled resulting computation returns a value of the same type
-- as the original computations returns plus a final resource of `State`.
-- I.e. this is like the usual `S -> B × S`, but, since the state is heterogeneous and
-- can depend on the value returned, it's more like `S -> Σ B T`.
-- Resources of all other effects remain untouched.
execState:∀{RsSrsBrs′}{Ψs:EffectsRs}->S->Eff(State,Ψs)(S,rs)Brs′->EffΨsrs(ΣB(head₁∘rs′))(tail₁∘rs′∘proj₁)execStates(returny)=return(y,s)execStates(simple(hereᵉa)k)witha...|Get=execStates(ks)...|Puts'=execStates'(ktt)execStates(simple(thereᵉa)k)=simpleaλx->execStates(kx)execStates(higher()k)openStateModulemoduleErrorModulewhere-- The error effect is almost the same as before, since its resource is trivial.
dataErrorE:Effect⊤whereThrow:E->ErrorE_⊥_-- Note that `throw` transforms initial resources into whatever other resources.
-- Indeed, we need to be able to throws errors via the `Error` effect in any part of
-- a computation: it's not required that initial and final resources must match --
-- `throw` is not `return`.
throw:∀{ΦsRsErsBrs′}{Ψs:EffectsRs}{{p:ErrorE,tt∈²Ψs,rs}}->E->HEffΦsΨsrsBrs′throw{{p}}e=invoke{{p}}(Throwe)>>=⊥-elim-- But this means that if a computation threw an error, it's not known in what state
-- resources were. I.e. resources became existential. Therefore in order to handle `Error`,
-- we must "deexistentialize" resources. Hence `execError` returns a computation that
-- returns `E ⊎ B` like before, but also attaches `Resources Rs` to `E`. I.e. if a computation
-- threw an error, then return also resources so we can make them final via `[ proj₂ , _ ]`
execError:∀{RsErsBrs′}{Ψs:EffectsRs}->Eff(ErrorE,Ψs)(tt,rs)Brs′->EffΨsrs(E×ResourcesRs⊎B)[proj₂,tail₁∘rs′]′execError(returny)=return(inj₂y)execError(simple(hereᵉ(Throwe))k)=return(inj₁(e,_))execError(simple(thereᵉa)k)=simpleaλx->execError(kx)execError(higher()k)-- But having exisentials means there is some CPS lying around.
-- Instead of returning resources on failing we can just handle errors such that
-- no matter what resources are, they are always transformed to what is required.
catchError:∀{RsErsBrs′}{Ψs:EffectsRs}->Eff(ErrorE,Ψs)(tt,rs)Brs′->(∀{rs}->E->EffΨsrsB(tail₁∘rs′))->EffΨsrsB(tail₁∘rs′)catchError(returny)h=returnycatchError(simple(hereᵉ(Throwe))k)h=hecatchError(simple(thereᵉa)k)h=simpleaλx->catchError(kx)hcatchError(higher()k)hopenErrorModulemoduleStateTestwhereopenimportData.Fin-- Here's an example.
-- final resources producer ----------------------------|
-- result is of type ----------------------------| |
-- initial resources ------------------| | |
-- effects ----------| | | |
fpred : Eff (Error ⊤ , State , tt) (tt , ℕ , tt) ℕ (λ n -> tt , Fin n , tt)fpred=get>>=λ{0->throwtt;(sucn)->zapℕ(fromℕn)>>return(sucn)}-- `fpred` gets the current state, if it's `0`, then it throws an error,
-- if it's `suc n`, then puts `fromℕ n` in the state and returns `suc n`.
-- Note that the type signature of `fpred` guarantees that the value in a final state
-- is always of type `Fin n` where `n` is what the computation returned.
-- And indeed `fromℕ n` has type `Fin (suc n)`.
-- If we try to return `n` instead of `suc n` we'll get the following very useful error:
-- No instance of type
-- ((Set , State , ℕ) ≡ (⊤ , Error ⊤ , tt) ⊎
-- (Set , State , ℕ) ≡ (Set , State , ℕ) ⊎ ⊥)
-- was found in scope.
-- But if we explicitly fill the instance argument to `zap` the error becomes
-- suc x != x of type ℕ
-- A more general type signature for `fpred`:
-- fpred : ∀ {Rs rs} {Ψs : Effects Rs}
-- {{err : Error ⊤ , tt ∈² Ψs , rs}} {{st : State , ℕ ∈² Ψs , rs}}
-- -> Eff Ψs rs ℕ (λ n -> replace₁ (Fin n) (to∈₁ st))
-- (Having to deal with `replace₁` is slightly annoying. Since resources are independent
-- on each other, we perhaps can do better).
-- A couple of tests:
-- state ----------------------------------------------------------------|
-- resources ----------------------------------------------------| |
-- error -------------------------------------------------| | |
test₀:(runEff∘execState0$execErrorfpred)≡(inj₁(tt,ℕ,tt),0)test₀=refl-- state ----------------------------------------------------|
-- result -----------------------------------------------| |
test₂:(runEff∘execState2 $ execErrorfpred)≡(inj₂2,Fin.suczero)test₂=reflmoduleGeneralModulewhere-- Now general recursion stuff. Imagine a function that receives a value and returns some other
-- value, but also performs various effectful calls and changes resources of effects.
-- A delayed recursive call must change resources as well, because that's what an actual
-- recursive call does. And hence we have a higher effect that transforms resources
-- of simple effects.
-- `General` is a true inductive family. See `rs′′` appears twice? The first one is what
-- you pass to the effect and the second one is what a whole computation returns.
-- I.e. a computation that has the `General A rs′ B rs′′` effect always returns `rs′′` as
-- a final resources producer. If it pretends to return something else, then this something else
-- unifies with `rs′′` once pattern matching on `Rec` is performed. This is just like with
-- `x ≡ y`: you can write distinct `x` and `y` there, but once you pattern matched on `refl`,
-- they're unified. Two appearances of `rs′` are treated similarly.
dataGeneral{Rs}A(rs′:A->ResourcesRs)(B:A->Set)(rs′′:∀{x}->Bx->ResourcesRs):HigherEffectwhereRec:∀{Ψs}x->GeneralArs′Brs′′Ψs(rs′x)(Bx)rs′′-- The `λ {_} → ...` part is due to the notorious hidden-lambda bug (see [7]).
rec:∀{ΦsRsA}{Ψs:EffectsRs}{rs′:A->ResourcesRs}{B:A->Set}{rs′′:∀{x}->Bx->ResourcesRs}{{p:(λ{_}→GeneralArs′Brs′′)∈Φs}}->∀x->HEffΦsΨs(rs′x)(Bx)rs′′rec=hinvoke∘Rec-- A function of type `Π A Φs Ψs (λ x -> rs′ x , B x , rs′′)` is a function
-- that receives a value of type `A`, can perform higher effects from `Φs` and
-- simple effects from Ψs. Its initial resources of effects are `rs′ x` for the `x` received,
-- it returns `B x` (for the same `x`) and the final resources producer is `rs′′`.
Π:∀{Rs}->(A:Set)->HigherEffects->EffectsRs->(A->ResourcesRs×ΣSetλB->B->ResourcesRs)->SetΠAΦsΨsF=∀x->letrs,B,rs′=FxinHEff(GeneralA(proj₁∘F)(proj₁∘proj₂∘F)(proj₂$proj₂(F_))∷Φs)ΨsrsBrs′-- At the value level the next three functions are just the same as their non-dependent
-- counterparts from the previous post.
execGeneral:∀{ΦsRsAx}{Ψs:EffectsRs}{rs′:A->ResourcesRs}{B:A->Set}{rs′′:∀{x}->Bx->ResourcesRs}->(∀x->HEffΦsΨs(rs′x)(Bx)rs′′)->HEff(GeneralArs′Brs′′∷Φs)Ψs(rs′x)(Bx)rs′′->HEffΦsΨs(rs′x)(Bx)rs′′execGeneral{Φs}{Rs}{A}{x}{Ψs}{rs′}{B}{rs′′}f=hexecEffreturnhwhere-- This is where the aforementioned unification plays its role.
-- Pattern matching on `Rec` reveals that universally quantified `rs` is actually `rs′ x`
-- and the final resources producers are unified too.
h:∀{rsBxrs′′′}->GeneralArs′Brs′′ΨsrsBxrs′′′->((y:Bx)->HEffΦsΨs(rs′′′y)(Bx)rs′′)->HEffΦsΨsrs(Bx)rs′′h(Recx)k=fx>>=k{-#NON_TERMINATING#-}execApply:∀{ΦsRsAF}{Ψs:EffectsRs}->ΠAΦsΨsF->∀x->HEffΦsΨs___execApplyfx=execGeneral(execApplyf)(fx)execPetrol:∀{ΦsRsA}{Ψs:EffectsRs}{F}{{p:∀{x}->Error⊤,tt∈²Ψs,proj₁(Fx)}}->ℕ->ΠAΦsΨsF->∀x->HEffΦsΨs___execPetrol0fx=throwttexecPetrol(sucn)fx=execGeneral(λx->execPetrolnfx)(fx)openGeneralModulemoduleTestGeneralwhereopenimportData.Finhiding(_+_)openimportData.VecasVechiding(_>>=_;sum)-- Here is a contrived example.
-- The type level reads as follows: `ones` receives a number and returns an effectful
-- computation that has the `State` and `General` effects; initially, a `Fin (suc n)` is
-- in the state; the computation returns a list of numbers `xs` and puts
-- a `Vec ℕ n × Fin (suc (sum xs))` into the state.
-- At the value level `ones` performs delayed recursive calls until the `Fin` in the state is
-- `zero`. An argument to delayed recursive calls grows at each call (from `n` to `suc n`).
-- When a `Fin` becomes `zero`, we put a vector of `0`s and `zero` into the state.
-- But since `n` was grown, the length of the vector is greater than original `n` and
-- hence after each delayed recursive call we truncate the vector (and also grow a `Fin`):
-- the `modify′ {{p}} (Product.map Vec.tail suc)` part. In order to be able to grow a `Fin`,
-- we must prepend `1` to the resulting list, because `suc` transforms a `Fin n` into a
-- `Fin (suc n)` and we can't violate the guarantees provided by type signature.
-- So `ones` truncates the `Fin` in the state before each recursive call, performs the call
-- and grows the `Fin` back, thus the `Fin` in a final state is always the same as in an initial.
ones:∀{Rs}{Ψs:EffectsRs}{rs:ResourcesRs}->Πℕ[](State,Ψs)λn->(Fin(sucn),rs),Listℕ,λxs->(Vecℕn×Fin(suc(sumxs))),rsonesn=get{{p}}>>=λ{zero->zap_{{p}}(Vec.replicate0,zero)>>return[];(suci)->zap_{{p}}(inject₁(inject₁i))>>rec{{p}}(sucn)>>=λxs->modify′{{p}}(Product.mapVec.tailsuc)>>return(1∷xs)}wherepatternp=inj₁refl-- `p` is a number of steps to perform, `i` is an initial `Fin` in the state.
run:ℕ->Fin4->⊤×⊤⊎∃λxs->Vecℕ3×Fin(suc(sumxs))runpi=runEff∘execError∘execStatei$execPetrolpones3test₀:∀{n}->run(sucn)zero≡inj₂([],0∷0∷0∷[],zero)test₀=refltest₁:run2(suczero)≡inj₂(1∷[],0∷0∷0∷[],suczero)test₁=refltest₂:∀{n}->run(3+n)(suc(suczero))≡inj₂(1∷1∷[],0∷0∷0∷[],suc(suczero))test₂=refltest₃:run3(suc(suc(suczero)))≡inj₁(tt,tt)test₃=reflmoduleCodensityModulewhereinfixl2 _⟨>>=⟩_ _⟨>>=⟩′_
infixr1 _⟨>>⟩_
-- Let's see another example of a higher effect.
-- Free monads and their relatives are known to be inefficient wrt left-nested binds.
-- The situation is similar to that of lists: left-nested appends result in quadratic performance,
-- while right-nested appends have linear performance. A common way to mitigate the situation
-- is to use difference lists: they have O(1) append and it takes O(n) time to reify a difference
-- list into an actual one. The same trick can be used to improve performance of free monads and
-- that's what [5] does.
-- [6] takes a different perspective: instead of performing binds the authors chose to collect
-- them in a data type which gives same O(1) `bind`. Their approach is much smarter than what
-- I'm going to show and I believe it should be adopted in a practical library (there would be
-- termination checking issues, but they probably can be solved with sized types), but
-- nevertheless this example is nice.
-- Here is the effect. Looks quite intimidating, right? But the idea is simple: we package
-- an effectful computation (which has this same `Codensity` effect too) with a bind continuation
-- instead of actually performing `_>>=_`.
dataCodensityΦs:HigherEffectwhereBind:∀{RsrsBrs′Crs′′}{Ψs:EffectsRs}->HEff(CodensityΦs∷Φs)ΨsrsBrs′->(∀y->HEffΦsΨs(rs′y)Crs′′)->CodensityΦsΨsrsCrs′′-- And this is what we get on invoking `Bind`. The idea is that left-nested calls to `_⟨>>=⟩_`
-- stack via the `Codensity` effect instead of being computed like with `_>>=_`.
-- Right-nested calls are disallowed so far, since the bind continuation doesn't have the
-- `Codensity` effect.
_⟨>>=⟩_:∀{ΦsRsrsBrs′Crs′′}{Ψs:EffectsRs}->HEff(CodensityΦs∷Φs)ΨsrsBrs′->(∀y->HEffΦsΨs(rs′y)Crs′′)->HEff(CodensityΦs∷Φs)ΨsrsCrs′′b⟨>>=⟩g=hinvoke(Bindbg)_⟨>>⟩_:∀{ΦsRsrs₁Brs₂Crs′′}{Ψs:EffectsRs}->HEff(CodensityΦs∷Φs)Ψsrs₁B(constrs₂)->HEffΦsΨsrs₂Crs′′->HEff(CodensityΦs∷Φs)Ψsrs₁Crs′′b⟨>>⟩c=b⟨>>=⟩constc-- Here we reassociate binds via CPS by growing the `k₃` continuation.
-- Just like with difference lists.
bindCodensity:∀{ΦsRsrsBrs′Crs′′}{Ψs:EffectsRs}->HEff(CodensityΦs∷Φs)ΨsrsBrs′->(∀y->HEffΦsΨs(rs′y)Crs′′)->HEffΦsΨsrsCrs′′bindCodensity(returny)k₃=k₃ybindCodensity(simpleak₂)k₃=simpleaλx->bindCodensity(k₂x)k₃bindCodensity(higher(hereʰᵉ(Bindak₁))k₂)k₃=bindCodensitya(k₁>=>λx->bindCodensity(k₂x)k₃)bindCodensity(higher(thereʰᵉa)k₂)k₃=higheraλx->bindCodensity(k₂x)k₃execCodensity:∀{ΦsRsrsBrs′}{Ψs:EffectsRs}->HEff(CodensityΦs∷Φs)ΨsrsBrs′->HEffΦsΨsrsBrs′execCodensityb=bindCodensitybreturn-- We can also have right-nested computations with the `Codensity` effect.
-- I don't know if we lose much by handling `Codenisty` so early or not, though.
_⟨>>=⟩′_:∀{ΦsRsrsBrs′Crs′′}{Ψs:EffectsRs}->HEff(CodensityΦs∷Φs)ΨsrsBrs′->(∀y->HEff(CodensityΦs∷Φs)Ψs(rs′y)Crs′′)->HEff(CodensityΦs∷Φs)ΨsrsCrs′′b⟨>>=⟩′g=b⟨>>=⟩execCodensity∘gopenCodensityModulemoduleTestCodensitywhere-- This is `replicateM` that generates left-nested `_>>_`s.
replicateLeftM:∀{ΦsRsrsB}{Ψs:EffectsRs}->ℕ->HEffΦsΨsrsB(constrs)->HEffΦsΨsrs⊤(constrs)replicateLeftM{Φs}{Rs}{rs}{B}{Ψs}ne=goneₜₜwhereeₜₜ=_<$>ego:ℕ->HEffΦsΨsrs⊤(constrs)->HEffΦsΨsrs⊤(constrs)go0a=returnttgo1a=ago(sucn)a=gon(a>>eₜₜ)-- This is `replicateM` that generates left-nested `_⟨>>⟩_`s.
replicateCoLeftM:∀{ΦsRsrsB}{Ψs:EffectsRs}->ℕ->HEffΦsΨsrsB(constrs)->HEff(CodensityΦs∷Φs)Ψsrs⊤(constrs)replicateCoLeftM{Φs}{Rs}{rs}{B}{Ψs}ne=gon(hshifteₜₜ)whereeₜₜ=_<$>ego:ℕ->HEff(CodensityΦs∷Φs)Ψsrs⊤(constrs)->HEff(CodensityΦs∷Φs)Ψsrs⊤(constrs)go0a=returnttgo1a=ago(sucn)a=gon(a⟨>>⟩eₜₜ)-- Uncomment this and memory consumption will grow from 117 MB to 880 MB.
-- test₁ : (proj₂ ∘ runEff ∘ execState 0 ∘ replicateLeftM 80 $ modify suc) ≡ 80
-- test₁ = refl
-- Uncomment this and memory consumption will grow from 117 MB to 160 MB.
-- This version type checks much faster as expected.
-- test₂ : (proj₂ ∘ runEff ∘ execState 0 ∘ execCodensity ∘ replicateCoLeftM 80 $ modify suc) ≡ 80
-- test₂ = refl
moduleReferenceswhere-- [1] "Turing-completeness totally freer"
-- http://effectfully.blogspot.com/2016/12/turing-completeness-totally-freer.html
-- [2] "The Effects Tutorial"
-- http://docs.idris-lang.org/en/latest/effects/
-- [3] "Inferring Precise Polymorphic Specifications for the Hoare State Monad",
-- Cole Schlesinger and Nikhil Swamy
-- http://research.microsoft.com/en-us/um/people/nswamy/paper.pdf
-- [4] "The Hoare State Monad", Wouter Swierstra
-- http://www.staff.science.uu.nl/~swier004/talks/2009-eindhoven.pdf
-- [5] "Asymptotic Improvement of Computations over Free Monads"
-- http://www.janis-voigtlaender.eu/papers/AsymptoticImprovementOfComputationsOverFreeMonads.pdf
-- [6] "Freer Monads, More Extensible Effects", Oleg Kiselyov, Hiromi Ishii
-- http://okmij.org/ftp/Haskell/extensible/more.pdf
-- [7] "Eliminating the problems of hidden-lambda insertion", Marcus Johansson, Jesper Lloyd
-- http://www2.tcs.ifi.lmu.de/~abel/MScThesisJohanssonLloyd.pdf