-- |-- Module: Control.Wire.Types-- Copyright: (c) 2011 Ertugrul Soeylemez-- License: BSD3-- Maintainer: Ertugrul Soeylemez <es@ertes.de>---- Types used in the netwire library.moduleControl.Wire.Types(-- * The wireWire(..),WireM,-- * Construction and destructionWireGen(..),WirePure(..),WireToGen(..),mkFixM,toGenM,-- * InhibitionLastException,inhibitException,inhibitMsg,-- * UtilitiesmapInputM)whereimportqualifiedControl.ExceptionasEximportControl.ApplicativeimportControl.ArrowimportControl.Arrow.OperationsimportControl.Arrow.TransformerimportControl.CategoryimportControl.MonadimportControl.Monad.FiximportControl.Monad.Reader.ClassimportControl.Monad.State.ClassimportControl.Monad.Writer.ClassimportControl.Wire.ClassesimportData.MonoidimportPreludehiding((.),id)-- | Convenience type for wire exceptions.typeLastException=LastEx.SomeException-- | Signal networks.datafamilyWire::*->(*->*->*)->*->*->*datainstanceWiree(Kleislim)abwhereWmGen::(a->m(Eithereb,Wiree(Kleislim)ab))->Wiree(Kleislim)abWmPure::(a->(Eithereb,Wiree(Kleislim)ab))->Wiree(Kleislim)ab-- | Choice at the functor level.instance(Monadm,Monoide)=>Alternative(Wiree(Kleislim)a)whereempty=zeroArrow(<|>)=(<+>)-- | Map a function signal over the output signal.instanceMonadm=>Applicative(Wiree(Kleislim)a)wherepure=mkPureFix.const.RightWmPureff<*>wx'@(WmPurefx)=WmPure$\x'->caseffx'of(Leftex,wf)->(Leftex,wf<*>wx')(Rightf,wf)->let(mx,wx)=fxx'in(fmapfmx,wf<*>wx)WmPureff<*>wx'@(WmGenfx)=WmGen$\x'->caseffx'of(Leftex,wf)->return(Leftex,wf<*>wx')(Rightf,wf)->liftM(fmapf***(wf<*>))(fxx')WmGenff<*>wx'@(WmPurefx)=WmGen$\x'->do(mf,wf)<-ffx'return$casemfofLeftex->(Leftex,wf<*>wx')Rightf->let(mx,wx)=fxx'in(fmapfmx,wf<*>wx)WmGenff<*>wx'@(WmGenfx)=WmGen$\x'->do(mf,wf)<-ffx'casemfofLeftex->return(Leftex,wf<*>wx')Rightf->liftM(fmapf***(wf<*>))(fxx')-- | Wire side channels.instanceMonadm=>Arrow(Wiree(Kleislim))wherearrf=mkPureFix$Right.ffirst(WmGenc)=WmGen$\(x',y)->do(mx,w)<-cx'return(fmap(,y)mx,firstw)first(WmPuref)=WmPure$\(x',y)->let(mx,w)=fx'in(fmap(,y)mx,firstw)second(WmGenc)=WmGen$\(x,y')->do(my,w)<-cy'return(fmap(x,)my,secondw)second(WmPuref)=WmPure$\(x,y')->let(my,w)=fy'in(fmap(x,)my,secondw)-- (&&&) combinator.WmGenc1&&&w2'@(WmGenc2)=WmGen$\x'->do(mx1,w1)<-c1x'casemx1ofLeftex->return(Leftex,w1&&&w2')Rightx1->do(mx2,w2)<-c2x'return(fmap(x1,)mx2,w1&&&w2)WmGenc1&&&w2'@(WmPureg)=WmGen$\x'->do(mx1,w1)<-c1x'casemx1ofLeftex->return(Leftex,w1&&&w2')Rightx1->let(mx2,w2)=gx'inreturn(fmap(x1,)mx2,w1&&&w2)WmPuref&&&w2'@(WmGenc2)=WmGen$\x'->let(mx1,w1)=fx'incasemx1ofLeftex->return(Leftex,w1&&&w2')Rightx1->do(mx2,w2)<-c2x'return(fmap(x1,)mx2,w1&&&w2)WmPuref&&&w2'@(WmPureg)=WmPure$\x'->let(mx1,w1)=fx'(mx2,w2)=gx'incasemx1ofLeftex->(Leftex,w1&&&w2')Rightx1->(fmap(x1,)mx2,w1&&&w2)-- (***) combinator.WmGenc1***w2'@(WmGenc2)=WmGen$\(x',y')->do(mx,w1)<-c1x'casemxofLeftex->return(Leftex,w1***w2')Rightx->do(my,w2)<-c2y'return(fmap(x,)my,w1***w2)WmGenc1***w2'@(WmPureg)=WmGen$\(x',g->(my,w2))->do(mx,w1)<-c1x'return$casemxofLeftex->(Leftex,w1***w2')Rightx->(fmap(x,)my,w1***w2)WmPuref***w2'@(WmGenc2)=WmGen$\(f->(mx,w1),y')->docasemxofLeftex->return(Leftex,w1***w2')Rightx->do(my,w2)<-c2y'return(fmap(x,)my,w1***w2)WmPuref***w2'@(WmPureg)=WmPure$\(f->(mx,w1),g->(my,w2))->casemxofLeftex->(Leftex,w1***w2')Rightx->(fmap(x,)my,w1***w2)-- | Support for choice (signal redirection).instanceMonadm=>ArrowChoice(Wiree(Kleislim))whereleftw'@(WmPuref)=WmPure$\mx'->casemx'ofLeftx'->fmapLeft***left$fx'Rightx'->(Right(Rightx'),leftw')leftw'@(WmGenc)=WmGen$\mx'->casemx'ofLeftx'->liftM(fmapLeft***left)(cx')Rightx'->return(Right(Rightx'),leftw')rightw'@(WmPuref)=WmPure$\mx'->casemx'ofRightx'->fmapRight***right$fx'Leftx'->(Right(Leftx'),rightw')rightw'@(WmGenc)=WmGen$\mx'->casemx'ofRightx'->liftM(fmapRight***right)(cx')Leftx'->return(Right(Leftx'),rightw')wl'@(WmPuref)+++wr'@(WmPureg)=WmPure$\mx'->casemx'ofLeftx'->(fmapLeft***(+++wr')).f$x'Rightx'->(fmapRight***(wl'+++)).g$x'wl'+++wr'=WmGen$\mx'->casemx'ofLeftx'->liftM(fmapLeft***(+++wr'))(toGenMwl'x')Rightx'->liftM(fmapRight***(wl'+++))(toGenMwr'x')wl'@(WmPuref)|||wr'@(WmPureg)=WmPure$\mx'->casemx'ofLeftx'->second(|||wr').f$x'Rightx'->second(wl'|||).g$x'wl'|||wr'=WmGen$\mx'->casemx'ofLeftx'->liftM(second(|||wr'))(toGenMwl'x')Rightx'->liftM(second(wl'|||))(toGenMwr'x')-- | Support for one-instant delays.instance(MonadFixm,Monoide)=>ArrowCircuit(Wiree(Kleislim))wheredelayx'=WmPure$\x->(Rightx',delayx)-- | Inhibition handling interface. See also the-- "Control.Wire.Trans.Exhibit" and "Control.Wire.Prefab.Event" modules.instanceMonadm=>ArrowErrore(Wiree(Kleislim))whereraise=mkPureFixLefthandle(WmPuref)wh'@(WmPurefh)=WmPure$\x'->let(mx,w)=fx'incasemxofLeftex->let(mxh,wh)=fh(x',ex)in(mxh,handlewwh)Right_->(mx,handlewwh')handlew'wh'=WmGen$\x'->do(mx,w)<-toGenMw'x'casemxofLeftex->do(mxh,wh)<-toGenMwh'(x',ex)return(mxh,handlewwh)Right_->return(mx,handlewwh')newError(WmPuref)=WmPure$(Right***newError).fnewError(WmGenc)=WmGen$liftM(Right***newError).ctryInUnless(WmPuref)ws'@(WmPurefs)we'@(WmPurefe)=WmPure$\x'->let(mx,w)=fx'incasemxofLeftex->let(mxe,we)=fe(x',ex)in(mxe,tryInUnlesswws'we)Rightx->let(mxs,ws)=fs(x',x)in(mxs,tryInUnlesswwswe')tryInUnlessw'ws'we'=WmGen$\x'->do(mx,w)<-toGenMw'x'casemxofLeftex->do(mxe,we)<-toGenMwe'(x',ex)return(mxe,tryInUnlesswws'we)Rightx->do(mxs,ws)<-toGenMws'(x',x)return(mxs,tryInUnlesswwswe')-- | When the target arrow is an 'ArrowKleisli', then the wire arrow is-- also an ArrowKleisli.instanceMonadm=>ArrowKleislim(Wiree(Kleislim))wherearrM=mkFix(Right^<<arrM)-- | Value recursion in the wire arrows. **NOTE**: Wires with feedback-- must *never* inhibit. There is an inherent, fundamental problem with-- handling the inhibition case, which you will observe as a fatal-- pattern match error.instance(MonadFixm,Monoide)=>ArrowLoop(Wiree(Kleislim))whereloopw'=WmGen$\x'->dorec(mx,w)<-toGenMw'(x',d)letd=either(error"Loop data dependency broken by inhibition")sndmxreturn(fmapfstmx,loopw)-- | Combining possibly inhibiting wires.instance(Monadm,Monoide)=>ArrowPlus(Wiree(Kleislim))whereWmGenc1<+>w2'@(WmGenc2)=WmGen$\x'->do(mx1,w1)<-c1x'casemx1ofRight_->return(mx1,w1<+>w2')Leftex1->do(mx2,w2)<-c2x'return(mapLeft(mappendex1)mx2,w1<+>w2)WmGenc1<+>w2'@(WmPureg)=WmGen$\x'->do(mx1,w1)<-c1x'casemx1ofRight_->return(mx1,w1<+>w2')Leftex1->let(mx2,w2)=gx'inreturn(mapLeft(mappendex1)mx2,w1<+>w2)WmPuref<+>w2'@(WmGenc2)=WmGen$\x'->let(mx1,w1)=fx'incasemx1ofRight_->return(mx1,w1<+>w2')Leftex1->do(mx2,w2)<-c2x'return(mapLeft(mappendex1)mx2,w1<+>w2)WmPuref<+>w2'@(WmPureg)=WmPure$\x'->let(mx1,w1)=fx'(mx2,w2)=gx'incasemx1ofRight_->(mx1,w1<+>w2')Leftex1->(mapLeft(mappendex1)mx2,w1<+>w2)-- | If the underlying arrow is a reader arrow, then the wire arrow is-- also a reader arrow.instanceMonadReaderrm=>ArrowReaderr(Wiree(Kleislim))wherereadState=mkFixM(const(liftMRightask))newReader(WmPuref)=WmPure(secondnewReader.f.fst)newReader(WmGenc)=WmGen$\(x',env)->liftM(secondnewReader)(local(constenv)(cx'))-- | If the underlying arrow is a state arrow, then the wire arrow is-- also a state arrow.instanceMonadStatesm=>ArrowStates(Wiree(Kleislim))wherefetch=mkFixM(const(liftMRightget))store=mkFixM(liftMRight.put)-- | Wire arrows are arrow transformers.instanceMonadm=>ArrowTransformer(Wiree)(Kleislim)wherelift(Kleislif)=mkFixM(liftMRight.f)-- | If the underlying arrow is a writer arrow, then the wire arrow is-- also a writer arrow.instanceMonadWriterwm=>ArrowWriterw(Wiree(Kleislim))wherewrite=mkFixM(liftMRight.tell)newWriter(WmPuref)=WmPure((fmap(,mempty)***newWriter).f)newWriter(WmGenc)=WmGen$\x'->do((mx,w),log)<-listen(cx')return(fmap(,log)mx,newWriterw)-- | The always inhibiting wire. The @zeroArrow@ is equivalent to-- "Control.Wire.Prefab.Event.never".instance(Monadm,Monoide)=>ArrowZero(Wiree(Kleislim))wherezeroArrow=mkPureFix(const$Leftmempty)-- | Sequencing of wires.instanceMonadm=>Category(Wiree(Kleislim))whereid=WmPure$\x->(Rightx,id)w2'@(WmGenc2).WmGenc1=WmGen$\x''->do(mx',w1)<-c1x''casemx'ofLeftex->return(Leftex,w2'.w1)Rightx'->do(mx,w2)<-c2x'return(mx,w2.w1)w2'@(WmGenc2).WmPureg=WmGen$\(g->(mx',w1))->docasemx'ofLeftex->return(Leftex,w2'.w1)Rightx'->do(mx,w2)<-c2x'return(mx,w2.w1)w2'@(WmPuref).WmGenc1=WmGen$\x''->do(mx',w1)<-c1x''return$casemx'ofLeftex->(Leftex,w2'.w1)Right(f->(mx,w2))->(mx,w2.w1)w2'@(WmPuref).WmPureg=WmPure$\(g->(mx',w1))->casemx'ofLeftex->(Leftex,w2'.w1)Right(f->(mx,w2))->(mx,w2.w1)-- | Map a function over the output signal.instanceMonadm=>Functor(Wiree(Kleislim)a)wherefmapf(WmGeng)=WmGen(liftM(fmapf***fmapf).g)fmapf(WmPureg)=WmPure((fmapf***fmapf).g)-- | Create a wire from the given transformation computation.classArrow(>~)=>WireGen(>~)where-- | Stateful variant.mkGen::(a>~(Eithereb,Wiree(>~)ab))->Wiree(>~)ab-- | Stateless variant.mkFix::Arrow(>~)=>(a>~Eithereb)->Wiree(>~)abmkFixc=letw=mkGen(arr(,w).c)inwinstanceMonadm=>WireGen(Kleislim)wheremkGen(Kleislic)=WmGencmkFix(Kleislic)=letw=WmGen(liftM(,w).c)inw-- | Monad-based wires.typeWireMem=Wiree(Kleislim)-- | Create a pure wire from the given transformation function.classArrow(>~)=>WirePure(>~)where-- | Stateful variant.mkPure::(a->(Eithereb,Wiree(>~)ab))->Wiree(>~)ab-- | Stateless variant.mkPureFix::(a->Eithereb)->Wiree(>~)abmkPureFixf=letw=mkPure(\x->(fx,w))inwinstanceMonadm=>WirePure(Kleislim)wheremkPure=WmPure-- | Convert the given wire to a generic arrow computation.classWireToGen(>~)wheretoGen::Wiree(>~)ab->(a>~(Eithereb,Wiree(>~)ab))instanceMonadm=>WireToGen(Kleislim)wheretoGen=Kleisli.toGenM-- | Turn an arbitrary exception to a wire exception.inhibitException::Ex.Exceptione=>e->LastExceptioninhibitException=Last.Just.Ex.toException-- | Turn a string into a 'userError' exception wrapped by-- 'LastException'.inhibitMsg::String->LastExceptioninhibitMsg=inhibitException.userError-- | Map a function over the input.mapInputM::Monadm=>(a'->a)->Wiree(Kleislim)ab->Wiree(Kleislim)a'bmapInputMf(WmPureg)=WmPure(second(mapInputMf).g.f)mapInputMf(WmGeng)=WmGen(liftM(second(mapInputMf)).g.f)-- | Map a function over the 'Left' value of an 'Either'.mapLeft::(e'->e)->Eithere'b->EitherebmapLeftf=either(Left.f)Right-- | Create a stateless wire from the given monadic computation.mkFixM::Monadm=>(a->m(Eithereb))->Wiree(Kleislim)abmkFixMf=letw=WmGen(liftM(,w).f)inw-- | Convert the given wire to a generic monadic computation.toGenM::Monadm=>Wiree(Kleislim)ab-- ^ Wire to convert.->a-- ^ Input value.->m(Eithereb,Wiree(Kleislim)ab)toGenM(WmGenc)=ctoGenM(WmPuref)=(return.f)