{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
--
-- Module      :  Base
-- Copyright   :
-- License     :  GPL (Just (Version {versionBranch = [3], versionTags = []}))
--
-- Maintainer  :  agocorona@gmail.com
-- Stability   :
-- Portability :
--
-- | See http://github.com/agocorona/transient
-- everithing in this module is exported in order to allow extensibility.
-----------------------------------------------------------------------------
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE DeriveDataTypeable        #-}
{-# LANGUAGE Rank2Types        #-}
-- show
module Transient.Internals where
-- /show

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
import           Control.Concurrent
import           Control.Concurrent.STM
import           System.Mem.StableName
import           Data.Maybe
import           GHC.Conc
import           Data.List
import           Data.IORef
import           System.Environment

{-# INLINE (!>) #-}
(!>) :: Show a => b -> a -> b
(!>) x y=   trace (show y) x
infixr 0 !>


data TransIO  x = Transient  {runTrans :: StateT EventF IO (Maybe x)}
type SData= ()

type EventId= Int

type TransientIO= TransIO

data EventF  = forall a b . EventF{meffects     :: Effects
                                  ,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    :: TVar[EventF]
                                  ,maxThread   :: Maybe (IORef Int)
                                  }
                                  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



runTransient :: TransIO x -> IO (Maybe x, EventF)
runTransient t= do
  th <- myThreadId
  let eventf0=  EventF baseEffects Nothing empty [] M.empty 0
          th False  Nothing  (unsafePerformIO $ newTVarIO []) Nothing


  runStateT (runTrans t) eventf0




-- | get the continuation context: closure, continuation, state, child threads etc
getCont :: TransIO EventF
getCont = Transient $ Just <$> get

-- | run the closure and the continuation context
runCont :: EventF -> StateIO (Maybe a)
runCont (EventF _ _ x fs _ _  _ _  _ _ _)= runTrans $ do
      r <- (unsafeCoerce x)
      (compose fs r)

-- | warning: radiactive untyped stuff. handle with care
getContinuations :: StateIO [a -> TransIO b]
getContinuations= do
  EventF _ _ _ fs _ _ _ _ _ _ _  <- get
  return $ unsafeCoerce fs

{-
runCont cont= do
     mr <- runClosure cont
     case mr of
         Nothing -> return Nothing
         Just r -> runContinuation cont r
-}


-- | compose a list of continuations
compose []= const empty
compose (f: fs)= \x -> f x >>= compose fs



-- | run the closure  (the 'x'  in 'x >>= f') of the current bind operation.
runClosure :: EventF -> StateIO (Maybe a)
runClosure (EventF _ _ x _ _ _ _ _ _ _ _) =  unsafeCoerce $ runTrans x

-- | run the continuation (the 'f' in 'x >>= f') of the current bind operation
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) <- get
    put $ EventF eff ev b ( unsafeCoerce c: fs) d e f g h i j

-- | run a chain of continuations. It is up to the programmer to assure by construction that
--  each continuation type-check with the next, that the parameter type match the input of the first
-- continuation.
-- Normally this makes sense if it stop the current flow with `stop` after the invocation
runContinuations :: [a -> TransIO b] -> c -> TransIO d
runContinuations fs x= (compose $ unsafeCoerce fs)  x

instance   Functor TransIO where
  fmap f mx=   -- Transient $ fmap (fmap f) $ runTrans 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,[])   -- !> "NEWIOREF"


         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 full2) $
                        let full'= head full2: full
                        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    -- !> "RUN f"
         was <- getData `onNothing` return NoRemote
         when (was == WasParallel) $  setData NoRemote                                    -- !>  ("was=",was)

         Log recovery _ full <- getData `onNothing` return (Log False [] [])

         if was== WasRemote  || (not recovery && was == NoRemote  && isNothing k)
         -- if the first operand was a remote request
         -- (so this node is not master and hasn't to execute the whole expression)
         -- or it was not an asyncronous term (a normal term without async or parallel
         -- like primitives) and is nothing
           then  do
             restoreStack fs
             return Nothing
           else do
             liftIO $ writeIORef rf  (k,full)

             mfdata <- gets mfData
             seq <- gets mfSequence

             setContinuation g appg fs

             x <- runTrans g             --  !> "RUN g"
             Log recovery _ full' <- getData `onNothing` return (Log False [] [])
             liftIO $ writeIORef rg  (x,full')
             restoreStack fs
             return $ k <*> x

restoreStack fs=
       modify $ \(EventF eff _ f _ a b c d parent children g1) ->
               EventF eff Nothing f fs a b c d parent children g1



-- | dynamic serializable data for logging
data IDynamic= IDyns String | forall a.(Read a, Show a,Typeable 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


instance Alternative TransIO where
  empty = Transient $ return  Nothing
  (<|>) = mplus

--  Transient f <|> Transient g= Transient $ do
--         k <-   f
--         x <-   g
--         return $ k <|> x



data RemoteStatus=   WasRemote | WasParallel | NoRemote deriving (Typeable, Eq, Show)

instance MonadPlus TransIO where
    mzero= empty
    mplus  x y=  Transient $ do
         mx <- runTrans x                -- !!> "RUNTRANS11111"
         was <- getData `onNothing` return NoRemote
         if was== WasRemote              -- !!> "check wasremote"
           then return Nothing           --  !> was
           else case mx of
             Nothing -> runTrans y      --  !!> "RUNTRANS22222"
             justx -> return justx

-- | a sinonym of empty that can be used in a monadic expression. it stop the
-- computation
stop :: Alternative m => m a
stop= empty

infixr 1  <**  ,  <***

-- | forces the execution of the second operand even if the first stop. Return the first result (experimental)
(<**) :: TransIO a -> TransIO b -> TransIO a
(<**) ma mb= Transient $ do
              fs  <- getContinuations
              setContinuation ma (\x -> mb >> return x)  fs
              a <- runTrans ma
              runTrans mb
              restoreStack fs
              return  a

atEnd= (<**)

-- | forces the execution of the second operand  if the first fails only if the first operand
-- is executed normally, that is , it is not a reexecution consequence of an internal event on it.
-- Return the first result
(<***) :: TransIO a -> TransIO b -> TransIO a
(<***) ma mb= Transient $ do
              a <- runTrans ma    -- !> "ma"
              runTrans  mb        -- !> "mb"
              return a


atEnd' = (<***)

instance Monoid a => Monoid (TransIO a) where
  mappend x y = mappend <$> x <*> y
  mempty= return mempty

-- | set the current closure and continuation for the current statement
setEventCont ::   TransIO a -> (a -> TransIO b) -> StateIO EventF
setEventCont x f  = do

   st@(EventF eff e _ fs d n  r applic  ch rc bs)  <- get
   let cont=  EventF eff e x ( unsafeCoerce f : fs) d n  r applic  ch rc bs
   put cont
   return cont

-- | reset the closure and continuation. remove inner binds than the previous computations may have stacked
-- in the list of continuations.
--resetEventCont :: Maybe a -> EventF -> StateIO (TransIO b -> TransIO b)
resetEventCont mx _=do
   st@(EventF eff e _ fs d n  r nr  ch rc bs)  <- 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
   return  id

tailsafe []=[]
tailsafe (x:xs)= xs

--refEventCont= unsafePerformIO $ newIORef baseEffects

baseEffects :: Effects

baseEffects x  x' f' = do
            c <-setEventCont x'  f'
            mk <- runTrans x
            t <- resetEventCont mk c
            return (t,mk)

instance Monad TransIO where

      return x = Transient $ return $ Just x

      x >>= f  = Transient $ do
--            effects <- gets effects -- liftIO $ readIORef refEventCont
            (t,mk) <- baseEffects x x f
            t $ case mk of
                 Just k  ->  runTrans (f k)

                 Nothing ->  return Nothing

--instance MonadTrans (Transient ) where
--  lift mx = Transient $ mx >>= return . Just

instance MonadIO TransIO where
  liftIO x = Transient $ liftIO x >>= return . Just --     let x= liftIO io in x `seq` lift x


-- * Threads

waitQSemB sem= atomicModifyIORef sem $ \n -> if n > 0 then(n-1,True) else (n,False)
signalQSemB sem= atomicModifyIORef sem  $ \n ->  (n + 1,())

-- | set the maximun number of threads for a procedure. It is useful to limit the
-- parallelization of transient code that uses `parallel` `spawn` and `waitEvents`
threads :: Int -> TransIO a -> TransIO a
threads n proc= Transient $ do
   msem <- gets maxThread
   sem <- liftIO $ newIORef n
   modify $ \s -> s{maxThread= Just sem}
   r <- runTrans proc
   modify $ \s -> s{maxThread = msem} -- restore it
   return r

-- | delete all the previous childs generated by the expressions and continue execution
-- of the current thread.
oneThread :: TransientIO a -> TransientIO a
oneThread comp=  do
   chs <- liftIO $ newTVarIO []
   r <-  comp
   modify $ \ s -> s{children= chs}
   killChilds
   return r



-- | add n threads to the limit of threads. If there is no limit, it set it
addThreads' :: Int -> TransIO ()
addThreads' n= Transient $ 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 $ Just ()

-- | assure that at least there are n threads available
addThreads n= Transient $ do
   msem <- gets maxThread
   case msem of
     Nothing -> return ()
     Just sem ->  liftIO $ modifyIORef sem $ \n' -> if n' > n then n' else  n
   return $ Just ()
--getNonUsedThreads :: TransIO (Maybe Int)
--getNonUsedThreads= Transient $ do
--   msem <- gets maxThread
--   case msem of
--    Just sem -> liftIO $ Just <$> readIORef sem
--    Nothing -> return Nothing


-- | The threads generated in the process passed as parameter will not be killed.
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

-- | The threads will be killed when the parent thread dies. That is the default.
-- This can be invoked to revert the effect of `freeThreads`
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

-- | kill all the child processes
killChilds :: TransientIO()
killChilds= Transient $  do
   cont <- get
   liftIO $  killChildren cont
   return $ Just ()

-- * extensible state: session data management

-- | Get the state data for the desired type if there is any.
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


-- | getData specialized for the Transient monad. if Nothing, the
-- monadic computation does not continue.
--
-- If there is no such data, `getSData`  silently stop the computation.
-- That may or may not be the desired behaviour.
-- To make sure that this does not get unnoticed, use this construction:
--
-- >  getSData <|> error "no data"
--
getSData ::  Typeable a => TransIO  a
getSData= Transient getData



-- | set session data for this type. retrieved with getData or getSData
-- Note that this is data in a state monad, that means that the update only affect downstream
-- in the monad execution. it is not a global state neither a per user or per thread state
-- it is a monadic state like the one of a state monad.
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)}

-- | a shorter name for setData
setSData ::  (MonadState EventF m, Typeable a) => a -> m ()
setSData = setData

delSessionData x=
  modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}

delSData :: ( MonadState EventF m,Typeable a) => a -> m ()
delSData= delSessionData

--withSData ::  ( MonadState EventF m,Typeable a) => (Maybe a -> a) -> m ()
--withSData f= modify $ \st -> st{mfData=
--    let dat = mfData st
--        mx= M.lookup typeofx dat
--        mx'= case mx of Nothing -> Nothing; Just x -> unsafeCoerce x
--        fx=  f mx'
--        typeofx= typeOf $ typeoff f
--    in  M.insert typeofx  (unsafeCoerce fx) dat}
--    where
--    typeoff :: (Maybe a -> a) -> a
--    typeoff = undefined
----

-- | generator of identifiers that are unique withing the current monadic sequence
-- They are not unique in the whole program.
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)]

-- | async calls

data StreamData a=  SMore a | SLast a | SDone | SError SomeException deriving (Typeable, Show,Read)


-- | variant of `parallel` that repeatedly executes the IO computation and kill the previously created childs
--
-- It is useful in single threaded problems where each event discard the computations spawned by
-- previous events
waitEvents ::   IO b -> TransIO b
waitEvents io= do
   SMore r <- parallel (SMore <$> io)
   return r

-- Multithreaded version of `waitEvents` that do not kill the computations spawned by previous events
waitEvents' ::   IO b -> TransIO b
waitEvents' io= do
   SMore r <- parallel (SMore <$> io)
   return r

-- | variant of `parallel` that execute the IO computation once, and kill the previous child threads
async  ::  IO b -> TransIO b
async io= do
   SLast r <- parallel  (SLast <$>io)
   return r

-- | variant that spawn free threads. Since there is no thread control, this is faster
spawn ::  IO b -> TransIO b
spawn io= freeThreads $ do
   SMore r <- parallel (SMore <$>io)
   return r





-- |  return empty to the current thread, in new thread, execute the IO action,
-- this IO action modify an internal buffer. then, executes the closure where `parallel` is located
-- In this new execution, since the buffer is filled, `parallel` return the content of this buffer.
-- Then it launch the continuation after it with this new value returned by the closure.
--
-- If the maximum number of threads, set with `threads` has been reached  `parallel` perform
-- the work sequentially, in the current thread.
-- So `parallel` means that 'it can be parallelized if there are thread available'
--
-- if there is a limitation of threads, when a thread finish, the counter of threads available
-- is increased so another `parallel` can make use of it.
--
-- The behaviour of `parallel` depend on `StreamData`; If `SMore`, `parallel` will excute again the
-- IO action. with `SLast`, `SDone` and `SError`, `parallel` will not repeat the IO action anymore.
parallel  ::    IO (StreamData b) -> TransIO (StreamData b)
parallel  ioaction= Transient $   do

    cont <- get                    -- !> "PARALLEL"
    case event cont of
     j@(Just _) -> do
        put cont{event=Nothing}
        return $ unsafeCoerce j
     Nothing -> do
        liftIO $ loop cont ioaction
        setData WasParallel
        return Nothing





-- executes the IO action and then the continuation included in the first parameter
loop :: EventF -> IO (StreamData t) -> IO ()
loop (cont'@(EventF eff e x fs a b c d _ childs g))  rec  =  do
  chs <- liftIO $ newTVarIO []
  let cont = EventF eff e x fs a b c d (Just cont') chs g
      iocont dat= do
          runStateT (runCont cont) cont{event= Just $ unsafeCoerce dat}
          return ()

      -- execute the IO computation and then the closure-continuation
      loop'= forkMaybe False cont $ do
         mdat <- threadDelay 0 >> rec
         case mdat of
             se@(SError _) ->  iocont se
             SDone ->          iocont SDone
             last@(SLast _) -> iocont last

             more@(SMore _) -> do
                  forkMaybe False cont $ iocont more
                  loop'

  loop'
  return ()
  where
  forkMaybe True cont proc = forkMaybe' True cont proc
  forkMaybe False cont proc = do
     dofork <- case maxThread cont of
                  Nothing -> return True
                  Just sem -> do
                    dofork <- waitQSemB sem
                    if dofork then  return True else return False
     forkMaybe' dofork cont proc

  forkMaybe' dofork cont proc=
         if dofork
            then  do
                 forkFinally1 (do
                     th <- myThreadId
                     hangThread cont' cont{threadId=th}  -- !!>  "thread created: "++ show th
                     proc)
                     $ \me -> do
                         case me of -- !> "THREAD END" of
                          Left  e -> do
                             when (fromException e /= Just ThreadKilled)$ liftIO $ print e
                             killChildren  cont  -- !!> "KILL RECEIVED" ++ (show $ unsafePerformIO myThreadId)

                          Right _ ->  when(not $ freeTh cont') $ do -- if was not a free thread
                             --  if parent is alive
                             --  then remove himself from the parent list (with free)
                             --  and pass his active children to his parent

                             th <- myThreadId
                             mparent <- free th cont
                             return ()

--                             case mparent of
--                              Nothing  ->  return()
--                              Just parent -> atomically $ do
--                                     chs' <- readTVar $ children cont
--                                     chs  <- (readTVar $ children parent)
--                                     writeTVar (children parent)$ chs ++ chs'
--                                     return ()

                         case maxThread cont of
                           Just sem -> signalQSemB sem
                           Nothing -> return ()
                 return ()




            else proc  -- !> "NO THREAD"

forkFinally1 :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally1 action and_then =
  mask $ \restore ->
    forkIO $ try (restore action) >>= and_then

free th env= do
  if isNothing $ parent env
   then  return Nothing  -- !!>  show th ++ " orphan"
   else do
    let msibling= fmap children $ parent env

    case msibling of
     Nothing -> return Nothing
     Just sibling  -> do
       found <- atomically $ do
                sbs <- readTVar sibling
                let (sbs', found) = drop [] th  sbs    -- !!> "search "++show th ++ " in " ++ show (map threadId sbs)
                when found $ writeTVar sibling sbs'    -- !> ("new list",map threadId sbs')
                return found
       if (not found && isJust (parent env))
         then free th $ fromJust $ parent env         -- !!> "toparent"
         else return $ Just env

   where
   drop processed th []= (processed,False)
   drop processed th (ev:evts)| th ==  threadId ev= (processed ++ evts, True)
                    | otherwise= drop (ev:processed) th evts

hangThread parent child = when(not $ freeTh parent) $ do
   let headpths= children parent
   atomically $ do
       ths <- readTVar headpths
       writeTVar headpths $  child:ths   -- !!>  "thread added: "++ show (threadId child)

-- | kill  all the child threads associated with the continuation context
killChildren cont  = do

     forkIO $ do
        let childs= children cont
        ths <- atomically $ do
           ths <- readTVar childs
           writeTVar childs []
           return ths
--        mapM_ killChildren ths       -- recursive not needed, event handlers do it

        mapM_ (killThread . threadId) ths   -- !!> ("KILLEVENT " ++ show (map threadId ths) ++
--                                                        if length ths <20 then ""
--                                                          else error "long list of threads" )
     return ()


type EventSetter eventdata response= (eventdata ->  IO response) -> IO ()
type ToReturn  response=  IO response

-- | deinvert an event handler. The first parameter is the event handler setter to be
-- deinverted. Usually it is the primitive provided by a framework to set an event handler
--
-- the second is the value to return to the event handler
-- it configures the event handler by calling the first parameter, that set the event
-- handler, with the current continuation
react
  :: Typeable eventdata
  => EventSetter eventdata response
  -> ToReturn  response
  -> TransIO eventdata
react setHandler iob= Transient $ do
        cont    <- get
        mEvData <- getData
        case mEvData of
          Nothing -> do
            liftIO $ setHandler $ \dat ->do
              runStateT (setData dat >> runCont cont) cont
              iob
            setSData WasParallel
            return Nothing
          Just dat -> do
             delSessionData dat
             return (Just  dat)





-- * non-blocking keyboard input

getLineRef= unsafePerformIO $ newTVarIO Nothing


roption= unsafePerformIO $ newMVar []

-- | install a event receiver that wait for a string and trigger the continuation when this string arrives.
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 $ putStrLn $ show ret ++ " chosen"
    return ret


-- | validates an input entered in the keyboard in non blocking mode. non blocking means that
-- the user can enter also anything else to activate other option
-- unlike `option`, wich watch continuously, input only wait for one valid response
input :: (Typeable a, Read a) => (a -> Bool) -> TransIO a
input cond= Transient . liftIO . atomically $ do
       mr <- readTVar getLineRef
       case mr of
         Nothing -> retry
         Just r ->
            case reads1 r  of
            (s,_):_ -> if cond s  --  !> show (cond s)
                     then do
                       writeTVar  getLineRef Nothing -- !>"match"
                       return $ Just s

                     else return Nothing
            _ -> return Nothing

-- | non blocking `getLine` with a validator
getLine' cond=    do
     atomically $ do
       mr <- readTVar getLineRef
       case mr of
         Nothing -> retry
         Just r ->
            case reads1 r of --  !> ("received " ++  show r ++ show (unsafePerformIO myThreadId)) of
            (s,_):_ -> if cond s -- !> show (cond s)
                     then do
                       writeTVar  getLineRef Nothing -- !>"match"
                       return s

                     else retry
            _ -> 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
    putStrLn "Press end to exit"
    inputLoop'  -- !> "started inputLoop"
    where

    inputLoop'= do
           r<- getLine
           processLine r
           inputLoop'

processLine r= do
--   when (r=="end") $ atomically $ writeTVar rexit ()
   let rs = breakSlash [] r
   mapM_ (\ r -> if (r=="end") then exit' $ Left "terminated by user" else do
                    threadDelay 1000
                    atomically . writeTVar  getLineRef $ Just r) rs

    where
    breakSlash :: [String] -> String -> [String]
    breakSlash s ""= s
    breakSlash res s=
      let (r,rest) = span(/= '/') s
      in breakSlash (res++[r]) $ tail1 rest
      where
      tail1 []=[]
      tail1 x= tail x

{-# NOINLINE rexit #-}
rexit= unsafePerformIO $ newEmptyMVar

-- | wait for the execution of `exit` and return the result
stay=   do
    mr <- takeMVar rexit
    case mr of
      Right Nothing -> stay
      Right (Just r) -> return r
      Left msg -> error msg

-- | keep the main thread running, initiate the asynchronous keyboard input and execute
-- the transient computation. It also read a slash separated list of string that are interpreted by
-- `option` and `input` as if they were entered by the keyboard
keep :: TransIO a -> IO a
keep mx = do
   forkIO inputLoop
   forkIO $ do
           runTransient $  mx >> liftIO (putMVar rexit  $ Right Nothing) -- to avoid takeMVar in a infinite loop
           return ()
   threadDelay 100000
   args <- getArgs
   let path = filter (\arg -> arg !! 0 == '/') args
   when (not (null path)) $ do
        putStr "Executing: " >> print (head path)
        processLine $  head path
   stay

-- | same than `keep`but do not initiate the asynchronous keyboard input.
-- Useful for debugging
keep' :: TransIO a -> IO a
keep' mx  = do

   forkIO $ do
           runTransient $  mx >>   liftIO (putMVar rexit  $ Right Nothing)   -- to avoid takeMVar in a infinite loop
           return ()
   threadDelay 100000

   stay

-- | force the finalization of the main thread and thus, all the Transient block (and the application
-- if there is no more code)
exit :: a -> TransIO a
exit x= do
  liftIO $  putMVar rexit .  Right $ Just   x
  stop

exit' x= liftIO $  putMVar rexit  x
-- | alternative operator for maybe values. Used  in infix mode
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'