{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module TFHOE.Repr.Host where

import Control.Monad.IO.Class (MonadIO(..))
import Data.IORef

import TFHOE.Lib.Control.Monad
import TFHOE.Expr

-- * Type 'Repr_Host'

-- | Host-circular interpreter,
-- producing a host-term of host-type @h@,
-- wrapped inside @fun@ because of 'Expr_Fun'
-- ability to control its callings ('inline', 'val', and 'lazy').
newtype Repr_Host fun h
 =      Repr_Host
 {    unRepr_Host :: fun h }
 deriving (Applicative, Functor, Monad, MonadIO)

instance MonadIO fun => Expr_Fun fun (Repr_Host fun) where
	type Fun_from_Repr (Repr_Host fun) = fun
	app = liftM2Join $ \f a -> Repr_Host $ f $ return a
	inline f = return $ unRepr_Host . f . Repr_Host
	val    f = return $ (>>= unRepr_Host . f . Repr_Host . return)
	lazy   f = return $ ((>>= unRepr_Host . f . Repr_Host) . expr_fun_lazy_share)
instance Monad repr => Expr_Bool (Repr_Host repr) where
	bool = return
	neg  = liftMJoin  $ return . not
	and  = liftM2Join $ \x y -> return $ x && y
	or   = liftM2Join $ \x y -> return $ x || y
instance Monad repr => Expr_Int (Repr_Host repr) where
	int = return
	add = liftM2Join $ \x y -> return $ x + y
--instance Monad m => Expr_Eq (Host m) where
--	eq = liftM2Join $ \x y -> return $ x == y

host_repr :: Repr_Host repr h -> repr h
host_repr = unRepr_Host

-- | Utility for storing arguments of 'lazy' into an 'IORef'.
expr_fun_lazy_share :: MonadIO m => m a -> m (m a)
expr_fun_lazy_share m = do
	r <- liftIO $ newIORef (False, m)
	return $ do
		(already_evaluated, m') <- liftIO $ readIORef r
		if already_evaluated
			then m'
			else do
				v <- m'
				liftIO $ writeIORef r (True, return v)
				return v