{-# LANGUAGE TypeOperators
            ,ScopedTypeVariables
            ,PostfixOperators
            ,NoMonomorphismRestriction
            ,BangPatterns
  #-}
{-# OPTIONS_GHC -fno-cse #-}
-- |
-- Module      : Data.OI
-- Copyright   : (c) Nobuo Yamashita 2011
-- License     : BSD3
-- Author      : Nobuo Yamashita
-- Maintainer  : nobsun@sampou.org
-- Stability   : experimental
--
-- Comonadic data type for representing interaction with outer world.
--
module Data.OI (
  -- * Data type
  OI
 ,(:->)

  -- * Converter an IO to an interaction function
 ,iooi

  -- * Drive an interaction function
 ,run

  -- * Primitive operators on the interaction data
 ,(=:)
 ,(?)
 ,(#)

  -- * Category class methods on (:->)
 ,idA
 ,(<.>)

  -- * Arrow class methods on (:->)
 ,arrA
 ,firstA

  -- * Embeding interaction data in data structure
 ,deTuple
 ,deTriple
 ,deList

  -- * Interaction combinators
 ,(>|>|)
 ,(|<|<)
 ,(>|->|)
 ,(|-|)
 ,(|<|)
 ,(|>|)
 ,(<|)
 ,(|>)
 ,(|><|)
 ,mapOI
 ,mapOI'
 ,zipWithOI
 ,zipWithOI'
 ,sequenceOI
 ,sequenceOI'
 ,mergeOI

 ) where

import Control.Applicative
import Control.Concurrent
import Control.Parallel
import Control.Comonad
import System.IO.Unsafe

data OI a = OI { variable :: LeftValueOf (IO a), value :: a }
type a :-> b = OI a -> b

-- | Binding operator
(=:)         ::  a -> a :-> a
x =: OI v y  =   assign ix v `pseq` y
                 where ix = return x

-- | Dereference operator
(?)           ::  a :-> a
(?) (OI _ x)  =   x

-- | Reference operator
(#)    ::  a -> OI a
(#) x  =   OI { variable = reference (return x), value = x }

--

instance Functor OI where
  fmap f = (#) . f . (?)

instance Monad OI where
  return = (#)
  x >>= f = f (x?)

instance Applicative OI where
  pure  = (#)
  (<*>) = (. (?)) . ((#) .) . (?)

instance Extend OI where
  duplicate = (#)

instance Comonad OI where
  extract = (?)

--

idA :: a :-> a
idA = (?)

(<.>) :: (b :-> c) -> (a :-> b) -> (a :-> c)
f <.> g = f . (#) . g

--

arrA :: (a -> b) -> (a :-> b)
arrA f = f . (?)

firstA :: (a :-> b) -> (a,c) :-> (b,c)
firstA f ac = case deTuple ac of (x,z) -> (f x, (z?))

-- | Embed interactions into tuple
deTuple :: OI (a,b) -> (OI a,OI b)
deTuple (OI vxy ~(x,y)) = assign io vxy `pseq` (OI vx x, OI vy y)
 where
  vx     = new0 ()
  vy     = new0 ()
  io     = (,) <$> unsafeInterleaveIO (dereference vx) <*> unsafeInterleaveIO (dereference vy)

-- | Embed interactions into triple
deTriple :: (a,b,c) :-> (OI a,OI b,OI c)
deTriple (OI vxyz ~(x,y,z)) = assign io vxyz `pseq` (OI vx x, OI vy y, OI vz z)
 where
  vx     = new0 ()
  vy     = new0 ()
  vz     = new0 ()
  io     = (,,) <$> unsafeInterleaveIO (dereference vx)
                <*> unsafeInterleaveIO (dereference vy)
                <*> unsafeInterleaveIO (dereference vz)

-- | Embed interactions into list
deList :: [a] :-> Maybe (OI a, OI [a])
deList (OI vxxs xxs)
 = assign io vxxs
   `pseq` case xxs of
      x:xs -> Just (OI vx x, OI vxs xs)
      _    -> Nothing
   where
     vx  = new0 ()
     vxs = new0 ()
     io  = (:) <$> (unsafeInterleaveIO (dereference vx)) <*> (unsafeInterleaveIO (dereference vxs))

-- | Connect two interactions into an interaction

(|<|<) :: (c -> d :-> e) -> (a -> b :-> c) -> (a -> (b,d) :-> e)
(f |<|< g) a bd = case deTuple bd of (b,d) -> f (g a b) d

(>|>|) :: (a -> b :-> c) -> (c -> d :-> e) -> (a -> (b,d) :-> e)
(>|>|) = flip (|<|<)

(>|->|) :: (a -> b :-> c) -> (a' -> b' :-> c') -> ((a,a') -> (b,b') :-> (c,c'))
(f >|->| g) (a,a') bb' = case deTuple bb' of (b,b') -> (f a b, g a' b')

(|-|) :: (a :-> b) -> (a' :-> b') -> (a,a') :-> (b,b')
(f |-| g) aa' = case deTuple aa' of (a,a') -> (f a, g a')

(|<|)  ::  (b -> c :-> d) -> (a :-> b) -> (a,c) :-> d
(f |<| g) ac = case deTuple ac of (a,c) -> f (g a) c

(|>|)  :: (a :-> b) -> (b -> c :-> d) -> (a,c) :-> d
(|>|) = flip (|<|)

infixr 1 |<|
infixl 1 |>|

(|>) :: (a :-> b) -> (b -> c) -> (a :-> c)
(|>) = flip (.)

(<|) :: (b -> c) -> (a :-> b) -> (a :-> c)
(<|) = (.)

(|><|) :: (q -> a :-> (p,c)) -> (p -> b :-> (q,d)) -> ((a,b)  :-> (c,d))
(f |><| g) rab = case deTuple rab of
  (ra,rb) -> (c,d)
   where 
     (x,c) = f y ra
     (y,d) = g x rb


-- | Map interaction function on an interaction list
mapOI :: (a :-> b) -> [a] :-> [b]
mapOI f xxs = case deList xxs of
  Just (x,xs) -> f x : mapOI f xs
  _           -> []

-- | Map interaction function on an interaction list (return results and remainings)
mapOI' :: (a :-> b) -> [a] :-> (OI [a],[b])
mapOI' f xxs = case deList xxs of
  Just (x,xs) -> (zs, f x:ys)
                 where (zs,ys) = mapOI' f xs
  _           -> (xxs,[])

-- | Zip a list and an interaction list
zipWithOI :: (a -> b :-> c) -> [a] -> [b] :-> [c]
zipWithOI _ [] _  = []
zipWithOI f (x:xs) yys = case deList yys of
  Just (y,ys) -> f x y : zipWithOI f xs ys
  _           -> []

-- | Zip a list and an interaction list (return results and remainings)
zipWithOI' :: (a -> b :-> c) -> [a] -> [b] :-> (OI [b],[c])
zipWithOI' _ []     yys = (yys,[])
zipWithOI' f (x:xs) yys = case deList yys of
  Just (y,ys) -> case zipWithOI' f xs ys of ~(rs,zs) -> (rs,f x y : zs)
  _           -> (yys,[])

-- | Sequencing interaction functions
sequenceOI :: [a :-> b] -> [a] :-> ()
sequenceOI (f:fs) xxs = case deList xxs of
  Just (x,xs) -> f x `pseq` sequenceOI fs xs
  Nothing     ->  ()
sequenceOI [] _ = ()

-- | Sequencing interaction functions (return remainings)
sequenceOI' :: [a :-> b] -> [a] :-> OI [a]
sequenceOI' (f:fs) xxs = case deList xxs of
  Just (x,xs) -> f x `pseq` sequenceOI' fs xs
  Nothing     ->  xxs
sequenceOI' [] xxs = xxs

-- | Merging two lists by using oracles
mergeOI :: [a] -> [a] -> [a] :-> [a]
mergeOI xs ys = iooi $ mergeIO xs ys

-- | Convert an IO to an interaction function
iooi            ::  IO a -> (a :-> a)
iooi io (OI vix x)  =   assign io vix `pseq` x

-- | Drive an interaction function
run        ::  (a :-> b) -> IO b
run pmain  =   do { vx <- newEmptyMVar
                  ; x  <- unsafeInterleaveIO (dereference vx)
                  ; return $! pmain (OI vx x)
                  }

-- 

type LeftValueOf = MVar

new0 :: () -> LeftValueOf a
new0 () = unsafePerformIO $ newEmptyMVar

reference :: a -> LeftValueOf a
reference = unsafePerformIO . newMVar

dereference :: LeftValueOf a -> a
dereference = unsafePerformIO . readMVar

assign :: a -> LeftValueOf a -> a
assign !x v = unsafePerformIO 
            $ do { s <- tryPutMVar v x
                 ; if s then return x else readMVar v
                 }