{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
-- | Interpreter to compute a host-term.
module Language.LOL.Symantic.Repr.Host where

import Control.Monad.IO.Class (MonadIO(..))
import Data.IORef
import qualified Data.Bool as Bool
import Prelude hiding (and, not, or)

import Language.LOL.Symantic.Lib.Control.Monad
import Language.LOL.Symantic.Expr

-- * Type 'Repr_Host'

-- | Interpreter's data.
--
-- NOTE: the host-type @h@ is wrapped inside @lam@ to let 'Sym_Lambda'
-- control its callings (see 'inline', 'val', and 'lazy').
newtype Repr_Host lam h
 =      Repr_Host
 {    unRepr_Host :: lam h }
 deriving (Applicative, Functor, Monad, MonadIO)

-- | Interpreter.
host_from_expr :: Repr_Host repr h -> repr h
host_from_expr = unRepr_Host

instance MonadIO lam => Sym_Lambda lam (Repr_Host lam) where
	type Lambda_from_Repr (Repr_Host lam) = lam
	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_lambda_lazy_share)
instance Monad repr => Sym_Bool (Repr_Host repr) where
	bool = return
	not  = liftMJoin  $ return . Bool.not
	and  = liftM2Join $ \x y -> return $ x && y
	or   = liftM2Join $ \x y -> return $ x || y
instance Monad repr => Sym_Int (Repr_Host repr) where
	int = return
	neg  = liftMJoin  $ return . negate
	add = liftM2Join $ \x y -> return $ x + y
--instance Monad repr => Sym_Eq (Repr_Host repr) where
--	eq = liftM2Join $ \x y -> return $ x == y

-- | Helper to store arguments of 'lazy' into an 'IORef'.
expr_lambda_lazy_share :: MonadIO m => m a -> m (m a)
expr_lambda_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