{-
Copyright 2010-2012 Cognimeta Inc.
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in
compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0Unless required by applicable law or agreed to in writing, software distributed under the License is
distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
or implied. See the License for the specific language governing permissions and limitations under the License.
-}{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, TupleSections #-}moduleCgm.Control.Concurrent.TThread(run2,runWithDeamon)whereimportPreludehiding(catch)importData.IntMapimportData.TypeableimportControl.ExceptionimportControl.MonadimportControl.ApplicativeimportControl.ConcurrentimportControl.Concurrent.STMimportCgm.Control.CombinatorsimportCgm.Data.BooldataTaskna=Taskn((Taskna->IO())->IO(a->a))dataStatena=State{val::a,nextId::Int,threads::IntMap(n,ThreadId,Bool),forcedCancel::Bool}dataAbort=Abortderiving(Show,Typeable)instanceExceptionAbort-- Not exported since it should not be thrown by anyone else -- Could malicious code still throw it, by catching it as SomeException, unpacking the exitential, and using throwTo on -- itself (myThreadId) or some other thread which has leaked its identity?-- When a task completes, it applies a transition function to the candidate return value. Whenever the cancel predicate is-- true for that value, or if a forced cancellation has been triggerred by an exception in a child thread or an abort request-- in the parent, then all tasks that have not yet been cancelled are cancelled. Tasks starting will start cancelled if-- the cancel predicate is true on the current value, or if forced cancellation has been triggerred.-- Users wil probably want to ensure that once the cancel predicate becomes true, it never becomes false again.-- This function should not be used with asynchronous exceptions in the parent thread (beyond the Abort exception-- that may be thrown by an outer invocation of this function). Any unhandled exception in a child will be rethrown (wrapped)-- in the parent, after all children have been cancelled and have completed. The user should only rely on this behavior-- to handle unexepected exceptions. Other exceptions should be caught and transformed into a value in the children, so-- that the cancellation predicate can determine if cancellation is appropriate, and that the result transformation function-- can determine the appropriate result (the caller of run can transform back some values into exceptions).run::forallna.[Taskna]->a->(a->Bool)->IOaruntasksinitialcancel=newChan>>=run'whererun'c=foldM(flipstartTransition)(Stateinitial0Data.IntMap.emptyFalse)tasks>>=handlerwherehandlers=dostate'@(Statea_ts_)<-readChanc>>=($s)bool(handlerstate')(returna)$Data.IntMap.nulltsstartTransition::Taskna->Statena->IO(Statena)startTransition(Tasknf)(Stateaitsfc)=dot<-forkIO(f(writeChanc.startTransition)>>=writeChanc.endTransition)letcancelT=fc||cancelawhencancelT$throwTotAbortreturn$Statea(i+1)(inserti(n,t,cancelT)ts)fcwhereendTransition::(a->a)->Statena->IO(Statena)endTransitionaf(Stateanexttsfc)=doletts'=deleteitsleta'=afats''<-bool(returnts')(foldWithKeycancelNonCancelled(returnts')ts')$notfc&&cancela'return(Statea'nextts'fc)wherecancelNonCancelled::Int->(n,ThreadId,Bool)->Id(IO(IntMap(n,ThreadId,Bool)))cancelNonCancelledi(n,t,x)=ifxthenidelse(>>=(<$throwTotAbort).adjust(const(n,t,True))i)-- A task represented as pair of a description, and an IO of a triple containing: -- 1) whether to attempt to cancel the other task, -- 2) our result when we finish first, which the other task will convert into a final result-- 3) a function from that result of the other task to the final result, to be used only if we finish secondtypeTask2cab=(String,IO(Task2Resultcab))typeTask2Resultcab=((Bool,a),b->c)dataUnexpectedTaskException=UnexpectedTaskExceptionBoolStringSomeExceptionderiving(Show,Typeable)dataConcurrentExceptions=ConcurrentExceptionsSomeExceptionSomeExceptionderiving(Show,Typeable)instanceExceptionUnexpectedTaskExceptioninstanceExceptionConcurrentExceptionsdataPeerTaskException=PeerTaskExceptionderiving(Show,Typeable)instanceExceptionPeerTaskException-- Unexpected exceptions in a child will be wrapped in an UnexpectedTaskException, and an asynchronous-- exception PeerTaskException will be thrown in the other task (if it has not already completed). In that case-- the PeerTaskException is expected by the run2 method, so it does not have to be handled in the child.-- If both children return an exception, then both are wrapped and the resulting pair is thrown as a ConcurrentExceptions.-- Child tasks are required to catch Abort (if the peer requests it), and produce a Task2Result-- TODO handle Abort in parent run2::Task2cab->Task2cba->IOcrun2(n1,task1)(n2,task2)=doh1@(_,m1)<-forkIOTtask1h2@(_,m2)<-forkIOTtask2letw1=UnexpectedTaskExceptionFalsen1letw2=UnexpectedTaskExceptionTruen2join$atomically$getEitherJust(firstCompletew2h2w1)(firstCompletew1h1w2)m1m2wherefirstComplete::Wrapper->ThreadHandles(Task2Resultcba)->Wrapper->EitherSomeException(Task2Resultcab)->IOcfirstCompletewl(tl,ml)wf=eitherexnormalwhereexef=dothrowTotlPeerTaskExceptionatomically(getJustml)>>=eitherexl(const$throwwrappedFirst)wherewrappedFirst=wfefexlel=maybetwoExceptions(const$throwwrappedFirst)(fromExceptionel::MaybePeerTaskException)wheretwoExceptions=throw$ConcurrentExceptions(SomeException$wlel)(SomeExceptionwrappedFirst)normal((cancel,intermediate),_)=dowhencancel$throwTotlAbortfinal<-atomically(getJustml)>>=either(throw.wl)(return.snd)return$finalintermediatetypeWrapper=SomeException->UnexpectedTaskExceptionrunWithDeamon::(String,IOc)->(String,IO())->IOcrunWithDeamon(n1,f1)(n2,f2)=run2(n1,handle(\(e::Abort)->errordeamonEnded)f1>>=\c->return((True,c),errordeamonEnded))(n2,handle(\(e::Abort)->return())f2>>return((True,()),id))wheredeamonEnded="Deamon ended spontaneously"typeThreadHandlesa=(ThreadId,STM(Maybe(EitherSomeExceptiona)))forkIOT::IOa->IO(ThreadHandlesa)forkIOTf=dov<-atomically$newTVarNothingt<-forkIO$handle(setv.Left)(f>>=setv.Right)return(t,readTVarv)wheresetv=atomically.writeTVarv.JustgetJust::STM(Maybea)->STMagetJust=(>>=mayberetryreturn)getEitherJust::(a->z)->(b->z)->STM(Maybea)->STM(Maybeb)->STMzgetEitherJustz1z2m1m2=m1>>=maybe(m2>>=mayberetry(return.z2))(return.z1)