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

import Control.Monad as Monad
import Control.Monad.IO.Class (MonadIO(..))
import Data.IORef
import qualified Data.Bool as Bool
import qualified Data.Maybe as Maybe
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 lam h -> lam 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 lam => Sym_Bool (Repr_Host lam) where
	bool = return
	not  = fmap Bool.not
	and  = liftM2 (&&)
	or   = liftM2 (||)
instance Monad lam => Sym_Int (Repr_Host lam) where
	int = return
	neg = fmap negate
	add = liftM2 (+)
instance MonadIO lam => Sym_Maybe lam (Repr_Host lam) where
	maybe n j m = do
		mm <- m
		Maybe.maybe n (\a -> j `app` return a) mm
instance Monad lam => Sym_Maybe_Cons (Repr_Host lam) where
	nothing = return Nothing
	just    = liftMJoin $ return . Just
instance Monad lam => Sym_If (Repr_Host lam) where
	if_ m ok ko = do
		m' <- m
		if m' then ok else ko
instance Monad lam => Sym_When (Repr_Host lam) where
	when m ok = do
		m' <- m
		Monad.when m' ok
instance Monad lam => Sym_Eq (Repr_Host lam) where
	eq = liftM2 (==)

--instance Monad lam => Sym_Eq (Repr_Host lam) 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