module Transient.Internals where
import Control.Applicative
import Control.Monad.State
import Data.Dynamic
import qualified Data.Map as M
import Data.Monoid
import Debug.Trace
import System.IO.Unsafe
import Unsafe.Coerce
import Control.Exception hiding (try,onException)
import qualified Control.Exception (try)
import Control.Concurrent
import GHC.Conc(unsafeIOToSTM)
import Control.Concurrent.STM hiding (retry)
import qualified Control.Concurrent.STM as STM (retry)
import System.Mem.StableName
import Data.Maybe
import Data.List
import Data.IORef
import System.Environment
import System.IO
import System.Exit
import qualified Data.ByteString.Char8 as BS
data TransIO x = Transient {runTrans :: StateT EventF IO (Maybe x)}
type SData= ()
type EventId= Int
type TransientIO= TransIO
data LifeCycle= Alive | Parent | Listener | Dead deriving (Eq,Show)
data EventF = forall a b . EventF{meffects :: ()
,event :: Maybe SData
,xcomp :: TransIO a
,fcomp :: [b -> TransIO b]
,mfData :: M.Map TypeRep SData
,mfSequence :: Int
,threadId :: ThreadId
,freeTh :: Bool
,parent :: Maybe EventF
,children :: MVar[EventF]
,maxThread :: Maybe (IORef Int)
,labelth :: IORef (LifeCycle,BS.ByteString)
}
deriving Typeable
type Effects= forall a b c.TransIO a -> TransIO a -> (a -> TransIO b)
-> StateIO (StateIO (Maybe c) -> StateIO (Maybe c), Maybe a)
instance MonadState EventF TransIO where
get = Transient $ get >>= return . Just
put x= Transient $ put x >> return (Just ())
state f = Transient $ do
s <- get
let ~(a, s') = f s
put s'
return $ Just a
type StateIO= StateT EventF IO
noTrans x= Transient $ x >>= return . Just
runTransient :: TransIO x -> IO (Maybe x, EventF)
runTransient t= do
th <- myThreadId
label <- newIORef $ (Alive,BS.pack "top")
childs <- newMVar []
let eventf0= EventF () Nothing empty [] M.empty 0
th False Nothing childs Nothing label
runStateT (runTrans t) eventf0
runTransState st x = runStateT (runTrans x) st
getCont :: TransIO EventF
getCont = Transient $ Just <$> get
runCont :: EventF -> StateIO (Maybe a)
runCont (EventF _ _ x fs _ _ _ _ _ _ _ _)= runTrans $ do
r <- unsafeCoerce x
compose fs r
runCont' cont= runStateT (runCont cont) cont
getContinuations :: StateIO [a -> TransIO b]
getContinuations= do
EventF _ _ _ fs _ _ _ _ _ _ _ _ <- get
return $ unsafeCoerce fs
compose []= const empty
compose (f: fs)= \x -> f x >>= compose fs
runClosure :: EventF -> StateIO (Maybe a)
runClosure (EventF _ _ x _ _ _ _ _ _ _ _ _) = unsafeCoerce $ runTrans x
runContinuation :: EventF -> a -> StateIO (Maybe b)
runContinuation (EventF _ _ _ fs _ _ _ _ _ _ _ _) =
runTrans . (unsafeCoerce $ compose $ fs)
setContinuation :: TransIO a -> (a -> TransIO b) -> [c -> TransIO c] -> StateIO ()
setContinuation b c fs = do
(EventF eff ev _ _ d e f g h i j k) <- get
put $ EventF eff ev b ( unsafeCoerce c: fs) d e f g h i j k
withContinuation c mx= do
EventF eff ev f1 fs d e f g h i j k<- get
put $ EventF eff ev mx ( unsafeCoerce c: fs) d e f g h i j k
r <- mx
restoreStack fs
return r
runContinuations :: [a -> TransIO b] -> c -> TransIO d
runContinuations fs x= (compose $ unsafeCoerce fs) x
instance Functor TransIO where
fmap f mx=
do
x <- mx
return $ f x
instance Applicative TransIO where
pure a = Transient . return $ Just a
f <*> g = Transient $ do
rf <- liftIO $ newIORef (Nothing,[])
rg <- liftIO $ newIORef (Nothing,[])
fs <- getContinuations
let
hasWait (_:Wait:_)= True
hasWait _ = False
appf k = Transient $ do
Log rec _ full <- getData `onNothing` return (Log False [] [])
(liftIO $ writeIORef rf (Just k,full))
(x, full2)<- liftIO $ readIORef rg
when (hasWait full ) $
let full'= head full: full2
in (setData $ Log rec full' full')
return $ Just k <*> x
appg x = Transient $ do
Log rec _ full <- getData `onNothing` return (Log False [] [])
liftIO $ writeIORef rg (Just x, full)
(k,full1) <- liftIO $ readIORef rf
when (hasWait full) $
let full'= head full: full1
in (setData $ Log rec full' full')
return $ k <*> Just x
setContinuation f appf fs
k <- runTrans f
was <- getData `onNothing` return NoRemote
when (was == WasParallel) $ setData NoRemote
Log recovery _ full <- getData `onNothing` return (Log False [] [])
if was== WasRemote || (not recovery && was == NoRemote && isNothing k )
then do
restoreStack fs
return Nothing
else do
when (isJust k) $ liftIO $ writeIORef rf (k,full)
setContinuation g appg fs
x <- runTrans g
Log recovery _ full' <- getData `onNothing` return (Log False [] [])
liftIO $ writeIORef rg (x,full')
restoreStack fs
k'' <- if was== WasParallel
then do
(k',_) <- liftIO $ readIORef rf
return k'
else return k
return $ k'' <*> x
restoreStack fs=
modify $ \(EventF eff _ f _ a b c d parent children g1 la) ->
EventF eff Nothing f fs a b c d parent children g1 la
readWithErr line=
let [(v,left)] = readsPrec 0 line
in (v `seq` return [(v,left)])
`catch` (\(e::SomeException) ->
error ("read error trying to read type: \"" ++ show( typeOf v) ++ "\" in: "++" <"++ show line++"> "))
readsPrec' _= unsafePerformIO . readWithErr
class (Show a, Read a, Typeable a) => Loggable a where
instance (Show a, Read a,Typeable a) => Loggable a where
data IDynamic= IDyns String | forall a.Loggable a => IDynamic a
instance Show IDynamic where
show (IDynamic x)= show $ show x
show (IDyns s)= show s
instance Read IDynamic where
readsPrec n str= map (\(x,s) -> (IDyns x,s)) $ readsPrec' n str
type Recover= Bool
type CurrentPointer= [LogElem]
type LogEntries= [LogElem]
data LogElem= Wait | Exec | Var IDynamic deriving (Read,Show)
data Log= Log Recover CurrentPointer LogEntries deriving (Typeable, Show)
instance Alternative TransIO where
empty = Transient $ return Nothing
(<|>) = mplus
data RemoteStatus= WasRemote | WasParallel | NoRemote deriving (Typeable, Eq, Show)
instance MonadPlus TransIO where
mzero= empty
mplus x y= Transient $ do
mx <- runTrans x
was <- getData `onNothing` return NoRemote
if was== WasRemote
then return Nothing
else
case mx of
Nothing -> runTrans y
justx -> return justx
stop :: Alternative m => m stopped
stop= empty
instance (Num a,Eq a) => Num (TransIO a) where
fromInteger = return . fromInteger
mf + mg = (+) <$> mf <*> mg
mf * mg = (*) <$> mf <*> mg
negate f = f >>= return . negate
abs f = f >>= return . abs
signum f = f >>= return . signum
class AdditionalOperators m where
(**>) :: m a -> m b -> m b
(<**) :: m a -> m b -> m a
atEnd' ::m a -> m b -> m a
atEnd' = (<**)
(<***) :: m a -> m b -> m a
atEnd :: m a -> m b -> m a
atEnd= (<***)
instance AdditionalOperators TransIO where
(**>) x y= Transient $ do
runTrans x
runTrans y
(<***) ma mb= Transient $ do
fs <- getContinuations
setContinuation ma (\x -> mb >> return x) fs
a <- runTrans ma
runTrans mb
restoreStack fs
return a
(<**) ma mb= Transient $ do
a <- runTrans ma
runTrans mb
return a
infixr 1 <*** , <**, **>
(<|) :: TransIO a -> TransIO b -> TransIO a
(<|) ma mb = Transient $ do
fs <- getContinuations
ref <- liftIO $ newIORef False
setContinuation ma (cont ref ) fs
r <- runTrans ma
restoreStack fs
return r
where
cont ref x= Transient $ do
n <- liftIO $ readIORef ref
if n == True
then return $ Just x
else do liftIO $ writeIORef ref True
runTrans mb
return $ Just x
instance Monoid a => Monoid (TransIO a) where
mappend x y = mappend <$> x <*> y
mempty= return mempty
setEventCont :: TransIO a -> (a -> TransIO b) -> StateIO EventF
setEventCont x f = do
st@(EventF eff e _ fs d n r applic ch rc bs la) <- get
let cont= EventF eff e x ( unsafeCoerce f : fs) d n r applic ch rc bs la
put cont
return cont
resetEventCont mx _=do
st@(EventF eff e _ fs d n r nr ch rc bs la) <- get
let f= \mx -> case mx of
Nothing -> empty
Just x -> (unsafeCoerce $ head fs) x
put $ EventF eff e (f mx) ( tailsafe fs) d n r nr ch rc bs la
return id
tailsafe []=[]
tailsafe (x:xs)= xs
instance Monad TransIO where
return = pure
x >>= f = Transient $ do
c <- setEventCont x f
mk <- runTrans x
resetEventCont mk c
case mk of
Just k -> runTrans (f k)
Nothing -> return Nothing
instance MonadIO TransIO where
liftIO mx=do
ex <- liftIO' $ (mx >>= return . Right) `catch` (\(e :: SomeException) -> return $ Left e)
case ex of
Left e -> back e
Right x -> return x
where
liftIO' x = Transient $ liftIO x >>= return . Just
waitQSemB sem= atomicModifyIORef sem $ \n -> if n > 0 then(n1,True) else (n,False)
signalQSemB sem= atomicModifyIORef sem $ \n -> (n + 1,())
threads :: Int -> TransIO a -> TransIO a
threads n proc= do
msem <- gets maxThread
sem <- liftIO $ newIORef n
modify $ \s -> s{maxThread= Just sem}
r <- proc <** (modify $ \s -> s{maxThread = msem})
return r
oneThread :: TransIO a -> TransIO a
oneThread comp= do
st <- get
chs <- liftIO $ newMVar []
label <- liftIO $ newIORef (Alive, BS.pack "oneThread")
let st' = st{parent=Just st,children= chs, labelth= label}
liftIO $ hangThread st st'
put st'
x <- comp
th<- liftIO myThreadId
chs <- liftIO $ readMVar chs
liftIO $ mapM_ (killChildren1 th ) chs
return x
where
killChildren1 :: ThreadId -> EventF -> IO ()
killChildren1 th state = do
ths' <- modifyMVar (children state) $ \ths -> do
let (inn, ths')= partition (\st -> threadId st == th) ths
return (inn, ths')
mapM_ (killChildren1 th ) ths'
mapM_ (killThread . threadId) ths'
labelState l= do
st <- get
liftIO $ atomicModifyIORef (labelth st) $ \(status,_) -> ((status,BS.pack l),())
printBlock= unsafePerformIO $ newMVar ()
showThreads :: MonadIO m => EventF -> m ()
showThreads st= liftIO $ withMVar printBlock $ const $ do
mythread <- myThreadId
putStrLn "---------Threads-----------"
let showTree n ch= do
liftIO $ do
putStr $ take n $ repeat ' '
(state,label) <- readIORef $ labelth ch
if BS.null label
then putStr . show $ threadId ch
else do BS.putStr label ; putStr . drop 8 . show $ threadId ch
when (state== Dead) $ putStr " dead"
putStrLn $ if mythread== threadId ch then " <--" else ""
chs <- readMVar $ children ch
mapM_ (showTree $ n+2) $ reverse chs
showTree 0 st
topState :: TransIO EventF
topState = do
st <- get
return $ toplevel st
where
toplevel st= do
case parent st of
Nothing -> st
Just p -> toplevel p
showState :: (Typeable a, MonadIO m, Alternative m) => String -> EventF -> m (Maybe a)
showState th top = resp
where
resp= do
let thstring= drop 9 . show $ threadId top
if thstring == th then getstate top else do
sts <- liftIO $ readMVar $ children top
foldl (<|>) empty $ map (showState th) sts
where
getstate st=
case M.lookup ( typeOf $ typeResp resp ) $ mfData st of
Just x -> return . Just $ unsafeCoerce x
Nothing -> return Nothing
typeResp :: m (Maybe x) -> x
typeResp= undefined
addThreads' :: Int -> TransIO ()
addThreads' n= noTrans $ do
msem <- gets maxThread
case msem of
Just sem -> liftIO $ modifyIORef sem $ \n' -> n + n'
Nothing -> do
sem <- liftIO (newIORef n)
modify $ \ s -> s{maxThread= Just sem}
return ()
addThreads n= noTrans $ do
msem <- gets maxThread
case msem of
Nothing -> return ()
Just sem -> liftIO $ modifyIORef sem $ \n' -> if n' > n then n' else n
return ()
freeThreads :: TransIO a -> TransIO a
freeThreads proc= Transient $ do
st <- get
put st{freeTh= True}
r <- runTrans proc
modify $ \s -> s{freeTh= freeTh st}
return r
hookedThreads :: TransIO a -> TransIO a
hookedThreads proc= Transient $ do
st <- get
put st{freeTh= False}
r <- runTrans proc
modify $ \st -> st{freeTh= freeTh st}
return r
killChilds :: TransIO()
killChilds= noTrans $ do
cont <- get
liftIO $ do
killChildren $ children cont
writeIORef (labelth cont) (Alive,mempty)
return ()
killBranch= noTrans $ do
st <- get
liftIO $ killBranch' st
killBranch' cont= liftIO $ do
killChildren $ children cont
let thisth= threadId cont
let mparent= parent cont
when (isJust mparent) $ modifyMVar_ (children $ fromJust mparent)
$ \sts -> return $ filter (\st -> threadId st /= thisth) sts
killThread $ thisth
getData :: (MonadState EventF m,Typeable a) => m (Maybe a)
getData = resp where
resp= gets mfData >>= \list ->
case M.lookup ( typeOf $ typeResp resp ) list of
Just x -> return . Just $ unsafeCoerce x
Nothing -> return Nothing
typeResp :: m (Maybe x) -> x
typeResp= undefined
getSData :: Typeable a => TransIO a
getSData= Transient getData
getState :: Typeable a => TransIO a
getState= getSData
setData :: (MonadState EventF m, Typeable a) => a -> m ()
setData x=
let t= typeOf x in modify $ \st -> st{mfData= M.insert t (unsafeCoerce x) (mfData st)}
modifyData :: (MonadState EventF m, Typeable a) => (Maybe a -> Maybe a) -> m ()
modifyData f= modify $ \st -> st{mfData=
let t= typeOf $ typeResp f
in M.alter alterf t (mfData st)}
where
typeResp :: (Maybe a -> b) -> a
typeResp= undefined
alterf mx =
let x' = case mx of
Just x -> Just $ unsafeCoerce x
Nothing -> Nothing
in unsafeCoerce $ f x'
modifyState :: (MonadState EventF m, Typeable a) => (Maybe a -> Maybe a) -> m ()
modifyState= modifyData
setState :: (MonadState EventF m, Typeable a) => a -> m ()
setState= setData
delData :: ( MonadState EventF m,Typeable a) => a -> m ()
delData x= modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
delState :: ( MonadState EventF m,Typeable a) => a -> m ()
delState= delData
try :: TransIO a -> TransIO a
try mx= do
sd <- gets mfData
mx <|> (modify (\ s ->s{mfData= sd}) >> empty)
sandbox :: TransIO a -> TransIO a
sandbox mx= do
sd <- gets mfData
mx <*** modify (\s ->s{mfData= sd})
genId :: MonadState EventF m => m Int
genId= do
st <- get
let n= mfSequence st
put st{mfSequence= n+1}
return n
getPrevId :: MonadState EventF m => m Int
getPrevId= do
n <- gets mfSequence
return n
instance Read SomeException where
readsPrec n str=
let [(s , r)]= read str in [(SomeException $ ErrorCall s,r)]
data StreamData a= SMore a | SLast a | SDone | SError SomeException deriving (Typeable, Show,Read)
waitEvents :: IO b -> TransIO b
waitEvents io= do
mr <- parallel (SMore <$> io)
case mr of
SMore x -> return x
SError e -> back e
async :: IO b -> TransIO b
async io= do
mr <- parallel (SLast <$> io)
case mr of
SLast x -> return x
SError e -> back e
sync :: TransIO a -> TransIO a
sync x= do
setData WasRemote
r <- x
delData WasRemote
return r
spawn= freeThreads . waitEvents
sample :: Eq a => IO a -> Int -> TransIO a
sample action interval= do
v <- liftIO action
prev <- liftIO $ newIORef v
waitEvents (loop action prev) <|> async (return v)
where
loop action prev= loop'
where
loop'= do
threadDelay interval
v <- action
v' <- readIORef prev
if v /= v' then writeIORef prev v >> return v else loop'
parallel :: IO (StreamData b) -> TransIO (StreamData b)
parallel ioaction= Transient $ do
cont <- get
case event cont of
j@(Just _) -> do
put cont{event=Nothing}
return $ unsafeCoerce j
Nothing -> do
liftIO $ atomicModifyIORef (labelth cont) $ \(_,lab) -> ((Parent,lab),())
liftIO $ loop cont ioaction
was <- getData `onNothing` return NoRemote
when (was /= WasRemote) $ setData WasParallel
return Nothing
loop :: EventF -> IO (StreamData t) -> IO ()
loop parentc rec = forkMaybe parentc $ \cont -> do
liftIO $ atomicModifyIORef (labelth cont) $ const ((Listener,BS.pack "wait"),())
let loop'= do
mdat <- rec `catch` \(e :: SomeException) -> return $ SError e
case mdat of
se@(SError _) -> setworker cont >> iocont se cont
SDone -> setworker cont >> iocont SDone cont
last@(SLast _) -> setworker cont >> iocont last cont
more@(SMore _) -> do
forkMaybe cont $ iocont more
loop'
where
setworker cont= liftIO $ atomicModifyIORef (labelth cont) $ const ((Alive,BS.pack "work"),())
iocont dat cont = do
let cont'= cont{event= Just $ unsafeCoerce dat}
runStateT (runCont cont') cont'
return ()
loop'
return ()
where
forkMaybe parent proc = do
case maxThread parent of
Nothing -> forkIt parent proc
Just sem -> do
dofork <- waitQSemB sem
if dofork then forkIt parent proc else proc parent
forkIt parent proc= do
chs <- liftIO $ newMVar []
label <- newIORef (Alive, BS.pack "work")
let cont = parent{parent=Just parent,children= chs, labelth= label}
forkFinally1 (do
th <- myThreadId
let cont'= cont{threadId=th}
when(not $ freeTh parent )$ hangThread parent cont'
proc cont')
$ \me -> do
case maxThread cont of
Just sem -> signalQSemB sem
Nothing -> when(not $ freeTh parent ) $ do
th <- myThreadId
(can,label) <- atomicModifyIORef (labelth cont) $ \(l@(status,label)) ->
((if status== Alive then Dead else status, label),l)
when (can/= Parent ) $ free th parent
return ()
forkFinally1 :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally1 action and_then =
mask $ \restore -> forkIO $ Control.Exception.try (restore action) >>= and_then
free th env= do
let sibling= children env
(sbs',found) <- modifyMVar sibling $ \sbs -> do
let (sbs', found) = drop [] th sbs
return (sbs',(sbs',found))
if found
then do
(typ,_) <- readIORef $ labelth env
if (null sbs' && typ /= Listener && isJust (parent env))
then free (threadId env) ( fromJust $ parent env)
else return ()
else return ()
where
drop processed th []= (processed,False)
drop processed th (ev:evts)| th == threadId ev= (processed ++ evts, True)
| otherwise= drop (ev:processed) th evts
hangThread parentProc child = do
let headpths= children parentProc
modifyMVar_ headpths $ \ths -> return (child:ths)
killChildren childs = do
ths <- modifyMVar childs $ \ths -> return ([],ths)
mapM_ (killChildren . children) ths
mapM_ (killThread . threadId) ths
react
:: Typeable eventdata
=> ((eventdata -> IO response) -> IO ())
-> IO response
-> TransIO eventdata
react setHandler iob= Transient $ do
cont <- get
case event cont of
Nothing -> do
liftIO $ setHandler $ \dat ->do
runStateT (runCont cont) cont{event= Just $ unsafeCoerce dat}
iob
was <- getData `onNothing` return NoRemote
when (was /= WasRemote) $ setData WasParallel
return Nothing
j@(Just _) -> do
put cont{event=Nothing}
return $ unsafeCoerce j
abduce = Transient $ do
st <- get
case event st of
Just _ -> do
put st{event=Nothing}
return $ Just ()
Nothing -> do
chs <- liftIO $ newMVar []
label <- liftIO $ newIORef (Alive, BS.pack "abduce")
liftIO $ forkIO $ do
th <- myThreadId
let st' = st{event= Just (),parent=Just st,children= chs, threadId=th,labelth= label}
liftIO $ hangThread st st'
runCont' st'
return()
return Nothing
getLineRef= unsafePerformIO $ newTVarIO Nothing
roption= unsafePerformIO $ newMVar []
option :: (Typeable b, Show b, Read b, Eq b) =>
b -> String -> TransIO b
option ret message= do
let sret= show ret
liftIO $ putStrLn $ "Enter "++sret++"\tto: " ++ message
liftIO $ modifyMVar_ roption $ \msgs-> return $ sret:msgs
waitEvents $ getLine' (==ret)
liftIO $ putStr "\noption: " >> putStrLn (show ret)
return ret
input :: (Typeable a, Read a,Show a) => (a -> Bool) -> String -> TransIO a
input cond prompt= Transient . liftIO $do
putStr prompt >> hFlush stdout
atomically $ do
mr <- readTVar getLineRef
case mr of
Nothing -> STM.retry
Just r ->
case reads1 r of
(s,_):_ -> if cond s
then do
unsafeIOToSTM $ print s
writeTVar getLineRef Nothing
return $ Just s
else return Nothing
_ -> return Nothing
getLine' cond= do
atomically $ do
mr <- readTVar getLineRef
case mr of
Nothing -> STM.retry
Just r ->
case reads1 r of
(s,_):_ -> if cond s
then do
writeTVar getLineRef Nothing
return s
else STM.retry
_ -> STM.retry
reads1 s=x where
x= if typeOf(typeOfr x) == typeOf "" then unsafeCoerce[(s,"")] else readsPrec' 0 s
typeOfr :: [(a,String)] -> a
typeOfr = undefined
inputLoop= do
r<- getLine
atomically $ writeTVar getLineRef Nothing
processLine r
inputLoop
processLine r= do
let rs = breakSlash [] r
liftIO $ mapM_ (\ r ->
atomically $ do
t <- readTVar getLineRef
when (isJust t) STM.retry
writeTVar getLineRef $ Just r ) rs
where
breakSlash :: [String] -> String -> [String]
breakSlash [] ""= [""]
breakSlash s ""= s
breakSlash res ('\"':s)=
let (r,rest) = span(/= '\"') s
in breakSlash (res++[r]) $ tail1 rest
breakSlash res s=
let (r,rest) = span(/= '/') s
in breakSlash (res++[r]) $ tail1 rest
tail1 []=[]
tail1 x= tail x
stay rexit= takeMVar rexit
`catch` \(e :: BlockedIndefinitelyOnMVar) -> return Nothing
newtype Exit a= Exit a deriving Typeable
keep :: Typeable a => TransIO a -> IO (Maybe a)
keep mx = do
liftIO $ hSetBuffering stdout LineBuffering
rexit <- newEmptyMVar
forkIO $ do
runTransient $ do
st <- get
setData $ Exit rexit
(async (return ()) >> labelState "input" >> liftIO inputLoop)
<|> do
option "ps" "show threads"
liftIO $ showThreads st
empty
<|> do
option "log" "inspect the log of a thread"
th <- input (const True) "thread number>"
ml <- liftIO $ showState th st
liftIO $ print $ fmap (\(Log _ _ log) -> reverse log) ml
empty
<|> do
option "end" "exit"
killChilds
liftIO $ putMVar rexit Nothing
empty
<|> mx
return ()
threadDelay 10000
execCommandLine
stay rexit
where
type1 :: TransIO a -> Either String (Maybe a)
type1= undefined
keep' :: Typeable a => TransIO a -> IO (Maybe a)
keep' mx = do
liftIO $ hSetBuffering stdout LineBuffering
rexit <- newEmptyMVar
forkIO $ do
runTransient $ do
setData $ Exit rexit
mx
return ()
threadDelay 10000
forkIO $ execCommandLine
stay rexit
execCommandLine= do
args <- getArgs
let mindex = findIndex (\o -> o == "-p" || o == "--path" ) args
when (isJust mindex) $ do
let i= fromJust mindex +1
when (length args >= i) $ do
let path= args !! i
putStr "Executing: " >> print path
processLine path
exit :: Typeable a => a -> TransIO a
exit x= do
Exit rexit <- getSData <|> error "exit: not the type expected" `asTypeOf` type1 x
liftIO $ putMVar rexit $ Just x
stop
where
type1 :: a -> TransIO (Exit (MVar (Maybe a)))
type1= undefined
onNothing :: Monad m => m (Maybe b) -> m b -> m b
onNothing iox iox'= do
mx <- iox
case mx of
Just x -> return x
Nothing -> iox'
data Backtrack b= Show b =>Backtrack{backtracking :: Maybe b
,backStack :: [EventF] }
deriving Typeable
backCut :: (Typeable reason, Show reason) => reason -> TransientIO ()
backCut reason= Transient $ do
delData $ Backtrack (Just reason) []
return $ Just ()
undoCut :: TransientIO ()
undoCut = backCut ()
onBack :: (Typeable b, Show b) => TransientIO a -> ( b -> TransientIO a) -> TransientIO a
onBack ac bac = registerBack (typeof bac) $ Transient $ do
Backtrack mreason _ <- getData `onNothing` backStateOf (typeof bac)
runTrans $ case mreason of
Nothing -> ac
Just reason -> bac reason
where
typeof :: (b -> TransIO a) -> b
typeof = undefined
onUndo :: TransientIO a -> TransientIO a -> TransientIO a
onUndo x y= onBack x (\() -> y)
registerBack :: (Typeable b, Show b) => b -> TransientIO a -> TransientIO a
registerBack witness f = Transient $ do
cont@(EventF _ _ x _ _ _ _ _ _ _ _ _) <- get
md <- getData `asTypeOf` (Just <$> backStateOf witness)
case md of
Just (bss@(Backtrack b (bs@((EventF _ _ x' _ _ _ _ _ _ _ _ _):_)))) ->
when (isNothing b) $ do
addrx <- addr x
addrx' <- addr x'
setData $ if addrx == addrx' then bss else Backtrack mwit (cont:bs)
Nothing -> setData $ Backtrack mwit [cont]
runTrans f
where
mwit= Nothing `asTypeOf` (Just witness)
addr x = liftIO $ return . hashStableName =<< (makeStableName $! x)
registerUndo :: TransientIO a -> TransientIO a
registerUndo f= registerBack () f
forward :: (Typeable b, Show b) => b -> TransIO ()
forward reason= Transient $ do
Backtrack _ stack <- getData `onNothing` (backStateOf reason)
setData $ Backtrack(Nothing `asTypeOf` Just reason) stack
return $ Just ()
retry= forward ()
noFinish= forward (FinishReason Nothing)
back :: (Typeable b, Show b) => b -> TransientIO a
back reason = Transient $ do
bs <- getData `onNothing` backStateOf reason
goBackt bs
where
goBackt (Backtrack _ [] )= return Nothing
goBackt (Backtrack b (stack@(first : bs)) )= do
(setData $ Backtrack (Just reason) stack)
mr <- runClosure first
Backtrack back _ <- getData `onNothing` backStateOf reason
case mr of
Nothing -> return empty
Just x -> case back of
Nothing -> runContinuation first x
justreason -> goBackt $ Backtrack justreason bs
backStateOf :: (Monad m, Show a, Typeable a) => a -> m (Backtrack a)
backStateOf reason= return $ Backtrack (Nothing `asTypeOf` (Just reason)) []
undo :: TransIO a
undo= back ()
newtype FinishReason= FinishReason (Maybe SomeException) deriving (Typeable, Show)
initFinish= backCut (FinishReason Nothing)
onFinish :: ((Maybe SomeException) ->TransIO ()) -> TransIO ()
onFinish f= onFinish' (return ()) f
onFinish' ::TransIO a ->((Maybe SomeException) ->TransIO a) -> TransIO a
onFinish' proc f= proc `onBack` \(FinishReason reason) ->
f reason
finish :: Maybe SomeException -> TransIO a
finish reason= back (FinishReason reason)
checkFinalize v=
case v of
SDone -> stop
SLast x -> return x
SError e -> back e
SMore x -> return x
onException :: Exception e => (e -> TransIO ()) -> TransIO ()
onException exc= return () `onException'` exc
onException' :: Exception e => TransIO a -> (e -> TransIO a) -> TransIO a
onException' mx f= onAnyException mx $ \e ->
case fromException e of
Nothing -> empty
Just e' -> f e'
where
onAnyException :: TransIO a -> (SomeException ->TransIO a) -> TransIO a
onAnyException mx f= mx `onBack` f
cutExceptions= backCut (undefined :: SomeException)
continue = forward (undefined :: SomeException)
catcht mx exc= sandbox $ do
cutExceptions
onException' mx exc
where
sandbox mx= do
exState <- getState <|> backStateOf (undefined :: SomeException)
mx
<*** setState exState