-- SUMMARY:
--
-- A module implementing the "Input", "Output" and "Var" data types.
--
-- An Input can be written to, an Output can be read, but you can also
-- wait for a change in the value, or retrieve the list of all values
-- assumed. A Var is a combination of an Input and an Output with the
-- same type for values.

-- INSPIRATION:
--
-- First of all, this is almost the same thing of Manuel Chakravarty's Ports
-- library. The Ports library has a great idea: provide both the stream-based 
-- approach and the monadic one, let the user decide.
--
-- Second: FRAN. In this library, you have a clear separation of
-- inputs and outputs, and a set of purely functional combinators to
-- create new inputs and outputs from existing ones.

-- ADVANTAGES:
-- 
-- A simple approach to (discretely) time-varying values. 
-- Both channels and mvars could be subsumed (but see issue n. 2, the read 
-- operation has no meaning on chans).
--
-- You can easily extend the state of a program. For example, after having written
-- the program, you can decide to make some variable persistent in a database.
-- This could be useful in conjunction with gconf, for a program's configuration.

-- ISSUES
-- 
-- 1.
-- To exit from the state of being a toy, this library needs the ability
-- to close outputs, but this is a problem, since the read operation becomes
-- undefined.
--
-- 2.
-- There might be cases in wich the read operation has no meaning, in wich the name
-- of "wires" could be more appropriate.
-- Maybe I should use type classes, but I am not sure of the disadvantages, there are
-- many. I will experiment soon.
--
-- 3.
-- At least an operation like "modifyMVar" should exist in Var's.
--
-- 4.
-- Var a = Input a + Output a OR ELSE Var a b = Input a + Output b, which doesn't seem a variable
-- but is more flexible? Or maybe Var a AND Wire a b?

module Var where

import Concurrent
import IORef
import GHC.IOBase
import IO
import Directory

data Input a = Input { putInput :: a -> IO () }

data Output a = Output { readOutput :: IO a,
		         waitOutput :: IO a,
		         listenOutput :: IO [a] }

data Var a = Var { varInput :: Input a,
		   varOutput :: Output a }

-- Perform an action when the output changes
onOutput :: Output a -> (a -> IO b) -> IO ()
onOutput o m = forkIO ( listenOutput o >>= mapM_ m) >> return ()

-- Utility functions for the variables
putVar :: Var a -> a -> IO ()
putVar = putInput . varInput

readVar :: Var a -> IO a
readVar = readOutput . varOutput

waitVar :: Var a -> IO a
waitVar = waitOutput . varOutput

listenVar :: Var a -> IO [a]
listenVar = listenOutput . varOutput

onVar :: Var a -> (a -> IO b) -> IO ()
onVar v m = onOutput (varOutput v) m

-- Some simple transformation

rmapInput ::  (b -> a) -> Input a -> Input b
rmapInput f i = Input { putInput = \ x -> putInput i (f x) }

mapOutput :: (a -> b) -> Output a -> Output b
mapOutput f o = Output { readOutput = readOutput o >>= return . f,
		         waitOutput = waitOutput o >>= return . f,
		         listenOutput = listenOutput o >>= return . (map f) }

coerceVar :: (b -> a) -> (a -> b) -> Var a -> Var b
coerceVar f1 f2 v = Var { varInput = rmapInput f1 (varInput v),
			  varOutput = mapOutput f2 (varOutput v) }

chain :: (a -> b) -> Output a -> Input b -> IO ()
chain f o i = onOutput o (putInput i . f)

chainIO :: (a -> IO b) -> Output a -> Input b -> IO ()
chainIO f o i = onOutput o (\ c -> f c >>= putInput i)

connectVar :: (a -> b) -> (b -> a) -> Var a -> Var b -> IO ()
connectVar f1 f2 v1 v2 = do
    onVar v1 (putVar v2 . f1)
    onVar v2 (putVar v1 . f2)

-- Do I need these?
constOutput :: a -> Output a
constOutput x = Output { readOutput = return x,
		         waitOutput = return x,
			 listenOutput = return [x] }

dummyInput :: Input a
dummyInput = Input { putInput = \ _ -> return () }

-- For each value of the output, execute a different action.
-- if the list of actions ends prematurely, just end processing.
processOutput :: Output a -> [a -> IO b] -> IO ()
processOutput o a = do
		    l <- listenOutput o
		    mapM_ (\ (a,b) -> a b) (zip a l)

-- For each value of the output, execute a different action
-- which does NOT depend on the value of the output.
-- Just an easier to write variant of processOutput.
-- eg: 
-- processOutput_ (buttonClick b) [print "Hi",print "all"]
--
-- instead of:
-- processOutput (buttonClick b) [\ () -> print "Hi",
--                                \ () -> print "all"]
processOutput_ :: Output a -> [IO b] -> IO ()
processOutput_ o a = do
		     l <- listenOutput o
		     sequence_ (map fst (zip a l))

-- Utility functions		
pairIO :: IO a -> IO b -> IO (a,b)
pairIO a1 a2 = 
    do  r1 <- unsafeInterleaveIO a1
	r2 <- unsafeInterleaveIO a2
	return (r1,r2)
	     
zipIO :: IO [a] -> IO [b] -> IO [(a,b)]
zipIO a1 a2 = 
    do r1 <- unsafeInterleaveIO a1
       r2 <- unsafeInterleaveIO a2
       return (zip r1 r2)

-- The zip functions on inputs and outputs
zipOutput :: Output a -> Output b -> Output (a,b)
zipOutput o1 o2 = Output { readOutput = do r1 <- readOutput o1 
			                   r2 <- readOutput o2
			                   return (r1,r2),
			   waitOutput = pairIO (waitOutput o1) (waitOutput o2),
			   listenOutput = zipIO (listenOutput o1) (listenOutput o2) }

zipInput :: Input a -> Input b -> Input (a,b)
zipInput i1 i2 = Input { putInput = \ (x,y) -> putInput i1 x >> putInput i2 y }

-- The merge function, quick & dirty
-- todo: rethink the library to allow 
-- mergeOutput :: Output a -> Output a -> Output a -- guess it's really important.
mergeOutput :: Output a -> Output a -> IO (Output a)
mergeOutput o1 o2 = do
		    r1 <- readOutput o1
		    v <- stateVar r1
		    onOutput o1 (putVar v)
		    onOutput o2 (putVar v)
		    return (varOutput v)

nmergeOutput :: [Output a] -> IO (Output a)
nmergeOutput [a,b] = mergeOutput a b
nmergeOutput (x:xs) = nmergeOutput xs >>= mergeOutput x


-- fold and scan families need definitions

-- Executes an action each n microseconds, giving () each time the
-- result differs from the previous one.
-- This is an example where there's no notion of current state at the
-- beginning of the computation, and it's wrongly implemented right now.
monitor :: Eq a => Int -> IO a -> IO (Output ())
monitor microsecs act =
    do v <- act >>= stateVar
       r <- stateVar () -- this is arbitrary, the read operation shouldn't be defined!
       forkIO ((sequence_ . repeat)
	       (do 
		new <- act
		old <- readVar v		        
		if old /= new then putVar v new >> putVar r () else return ()
		threadDelay microsecs))
       return (varOutput r)

-- In case you were wondering why I needed "monitor" :-)
watchFile :: Int -> FilePath -> IO (Output ())
watchFile microsecs file = monitor microsecs (getModificationTime file)

-- Just a small experiment; it works. If there is a portable way of
-- locking a file in haskell, just tell me! I ensured a simple locking in
-- this application, but it's obviously not enough.
mkPersistent :: (Read a,Show a) => Int -> FilePath -> Var a -> IO ()
mkPersistent microsecs file var = 
    do hd <- readVar var
       mutex <- newMVar ()
       w <- watchFile microsecs file
       wrt hd
       onVar var (\ x -> withMVar mutex (\ () -> wrt x))
       onOutput w (\ () -> withMVar mutex (\ () -> rd var))
    where
       wrt = \ v -> do h <- openFile file WriteMode
		       hPutStr h (show v)
		       hClose h
       rd = \ v -> do h <- openFile file ReadMode
		      l <- hGetContents h
		      putVar v (read l)


-- A possible implementation of a thread safe state variable: stateVar
--
-- The implementation sucks, but it works and it's implemented using
-- mvars and channels (so I can trust it). Layout is hard; buy a wide-screen monitor ;)
stateVar :: a -> IO (Var a)
stateVar value = do
    lock <- newMVar ()
    listeners <- newIORef []
    waiters <- newIORef []    
    currentValue <- newIORef value
    return Var { varInput = Input { putInput = \ v -> withMVar lock $ \ _ -> 
				    (do 
				     writeIORef currentValue v 
				     r <- readIORef listeners
				     mapM_ (flip writeChan v) r
				     s <- readIORef waiters
				     mapM_ (flip putMVar v) s) },

		 varOutput = Output { readOutput = withMVar lock (\_ -> readIORef currentValue),
				      waitOutput = (withMVar lock (\_ -> do 
								   v <- newEmptyMVar
								   modifyIORef waiters (v:)
								   return v) >>=
				                    takeMVar),
				      listenOutput = (withMVar lock $ \_ -> (do 
									     c <- newChan
									     modifyIORef listeners (c:)
									     return c) >>=
						      getChanContents) } }