{-# LANGUAGE DeriveDataTypeable #-}

{- |

'Sink's are a more flexible alternative to lazy I/O
('unsafeInterleaveIO'). Lazy I/O conflates evaluation with execution;
a value obtained from 'unsafeInterleaveIO' can perform side-effects
during the evaluation of pure code. Like lazy I/O, a 'Sink' provides a
way to obtain the value of the result of an 'IO' action before the
action has been executed, but unlike lazy I/O, it does not enable pure
code to perform side-effects. Instead, the value is explicitly
assigned by a later 'IO' action; repeated attempts to assign the value
of a 'Sink' fail. The catch is that this explicit assignment must
occur before the value is forced, so just like with lazy I/O, you
can't get away with completely ignoring evaluation order without
introducing bugs. However, violating this condition does not violate
purity because if the value is forced before it has been assigned, it
is ⊥.

In practice, using 'Sink's instead of 'unsafeInterleaveIO' requires a
bit more 'IO' boilerplate. The main practical difference is that while
'unsafeInterleaveIO' requires you to reason about effects from the
point of view of pure code, 'Sink's require you to reason about
evaluation order of pure code from the point of view of 'IO'; the 'IO'
portion of your program will have to be aware of what data is
necessary to produce *for* your pure code in order to be able to
consume the output it expects *from* your pure code.

-}
module Data.Sink ( Sink (), newSinkMsg, newSink, tryWriteSink, writeSink
                 , MultipleWrites (..)
                 ) where

import Control.Applicative
import Control.Exception
import Control.Monad
import Data.IORef
import Data.Maybe
import Data.Typeable
import System.IO.Unsafe (unsafeInterleaveIO)

-- | A write-once reference
newtype Sink a = Sink (IORef (Maybe a))
               deriving (Eq, Typeable)

-- | Create a new 'Sink' and a pure value. If you force the value
-- before writing to the 'Sink', the value is ⊥. If you write to the
-- 'Sink' before forcing the value, the value will be whatever you
-- wrote to the 'Sink'. The 'String' argument is an error message in
-- case you force the value before writing to the 'Sink'.
newSinkMsg :: String -> IO (Sink a, a)
newSinkMsg msg = do
  ref <- newIORef Nothing
  x <- unsafeInterleaveIO $ fromMaybe (error msg) <$> readIORef ref
  return (Sink ref, x)

-- | Create a new 'Sink' with a default error message.
newSink :: IO (Sink a, a)
newSink = newSinkMsg "Evaluated an unwritten sink"

-- | Attempt to assign a value to a 'Sink'. If the 'Sink' was
-- previously unwritten, write the value and return 'True', otherwise
-- keep the old value and return 'False'. This is an atomic (thread
-- safe) operation.
tryWriteSink :: Sink a -> a -> IO Bool
tryWriteSink (Sink ref) x =
  atomicModifyIORef ref $ maybe (Just x, True) (\y -> (Just y, False))

-- | Attempt to assign a value to a 'Sink'. If the 'Sink' had already
-- been written to, throw a 'MultipleWrites' exception. This is an
-- atomic (thread safe) operation.
writeSink :: Sink a -> a -> IO ()
writeSink sink x = do
  success <- tryWriteSink sink x
  unless success $ throwIO MultipleWrites

-- | An exception that is throw by 'writeSink' if you attempt to write
-- to a 'Sink' more than once.
data MultipleWrites = MultipleWrites
                    deriving (Show, Typeable)

instance Exception MultipleWrites