{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
-- | Interpreter to compute a host-term.
module Language.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 qualified Data.List as List
import qualified Data.Ord as Ord
import qualified Data.Map.Strict as Map
import Prelude hiding (and, not, or, compare)

import Language.Symantic.Lib.Control.Monad
import Language.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 Monad lam => Sym_Maybe (Repr_Host lam) where
	nothing = return Nothing
	just    = liftMJoin $ return . Just
instance MonadIO lam => Sym_Maybe_Lam 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_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_Ord (Repr_Host lam) where
	compare = liftM2 Ord.compare
instance Monad lam => Sym_List (Repr_Host lam) where
	list_empty = return []
	list_cons  = liftM2 (:)
instance MonadIO lam => Sym_List_Lam lam (Repr_Host lam) where
	list_filter f = liftMJoin go
		where
		go [] = return []
		go (x:xs) = do
			b <- f `app` return x
			(if b then ((x :) <$>) else id)
			 (go xs)
instance Monad lam => Sym_Tuple2 (Repr_Host lam) where
	tuple2 = liftM2 (,)
instance Monad lam => Sym_Map (Repr_Host lam) where
	map_from_list = fmap Map.fromList
instance MonadIO lam => Sym_Map_Lam lam (Repr_Host lam) where
	map_map f = liftMJoin $ sequence . ((\a -> f `app` return a) <$>)

-- | 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