{-# LANGUAGE DeriveFunctor, CPP #-}-- | A bit like 'Fence', but not thread safe and optimised for avoiding taking the fencemoduleGeneral.Wait(Wait (Now ,Later ),runWait ,quickly ,fromLater ,firstJustWaitUnordered ,firstLeftWaitUnordered )whereimportControl.Monad.ExtraimportControl.Monad.IO.ClassimportData.IORef.ExtraimportData.List.ExtraimportData.Primitive.ArrayimportGHC.Exts(RealWorld)#if __GLASGOW_HASKELL__ >= 800
importControl.Monad.Fail#endif
runWait::Monadm =>Wait m a ->m (Wait m a )runWait (Lift x )=runWait =<<x runWaitx =returnx fromLater::Monadm =>Wait m a ->(a ->m ())->m ()fromLater (Lift x )f =dox <-x ;fromLater x f fromLater(Now x )f =f x fromLater(Later x )f =x f quickly::Functorm =>m a ->Wait m a quickly =Lift .fmapNow dataWait m a =Now a |Lift (m (Wait m a ))|Later ((a ->m ())->m ())derivingFunctorinstance(Monadm ,Applicativem )=>Applicative(Wait m )wherepure =Now Now x <*> y =x <$>y Lift x <*>y =Lift $(<*>y )<$>x Later x <*>Now y =Later $\c ->x $\x ->c $x y -- Note: We pull the Lift from the right BEFORE the Later, to enable parallelismLater x <*>Lift y =Lift $doy <-y ;return$Later x <*>y Later x <*>Later y =Later $\c ->x $\x ->y $\y ->c $x y instance(Monadm ,Applicativem )=>Monad(Wait m )wherereturn =pure(>> )=(*>)Now x >>= f =f x Lift x >>=f =Lift $dox <-x ;return$x >>=f Later x >>=f =Later $\c ->x $\x ->dox <-runWait $f x casex ofNow x ->c x _->fromLater x c instance(MonadIOm ,Applicativem )=>MonadIO(Wait m )whereliftIO =Lift .liftIO.fmapNow #if __GLASGOW_HASKELL__ >= 800
instanceMonadFailm =>MonadFail(Wait m )wherefail =Lift .Control.Monad.Fail.fail#endif
firstJustWaitUnordered::MonadIOm =>(a ->Wait m (Maybeb ))->[a ]->Wait m (Maybeb )firstJustWaitUnordered f =go [].mapf where-- keep a list of those things we might visit later, and ask for each we see in turngo::MonadIOm =>[(Maybea ->m ())->m ()]->[Wait m (Maybea )]->Wait m (Maybea )go later (x :xs )=casex ofNow (Justa )->Now $Justa Now Nothing->go later xs Later l ->go (l :later )xs Lift x ->Lift $dox <-x return$go later (x :xs )go[][]=Now Nothinggo[l ][]=Later l gols []=Later $\callback ->doref <-liftIO$newIORef$lengthls forM_ls $\l ->l $\r ->doold <-liftIO$readIORefref when(old >0)$caser ofJusta ->doliftIO$writeIORef'ref 0callback $Justa Nothing->doliftIO$writeIORef'ref $old -1when(old ==1)$callback NothingfirstLeftWaitUnordered::(Applicativem ,MonadIOm )=>(a ->Wait m (Eithere b ))->[a ]->Wait m (Eithere [b ])firstLeftWaitUnordered f xs =doletn =lengthxs mut <-liftIO$newArrayn undefinedres <-go mut []$zipFrom0$mapf xs caseres ofJuste ->return$Lefte Nothing->liftIO$Right<$>mapM(readArraymut )[0..n -1]where-- keep a list of those things we might visit later, and ask for each we see in turngo::(Applicativem ,MonadIOm )=>MutableArrayRealWorldb ->[(Int,(Eithere b ->m ())->m ())]->[(Int,Wait m (Eithere b ))]->Wait m (Maybee )go mut later ((i ,x ):xs )=casex ofNow (Lefte )->Now $Juste Now (Rightb )->doliftIO$writeArraymut i b go mut later xs Later l ->go mut ((i ,l ):later )xs Lift x ->Lift $dox <-x return$go mut later ((i ,x ):xs )go_[][]=Now Nothinggomut ls []=Later $\callback ->doref <-liftIO$newIORef$lengthls forM_ls $\(i ,l )->l $\r ->doold <-liftIO$readIORefref when(old >0)$caser ofLefta ->doliftIO$writeIORef'ref 0callback $Justa Rightv ->doliftIO$writeArraymut i v liftIO$writeIORef'ref $old -1when(old ==1)$callback Nothing