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

import Data.Functor as Functor
import Control.Applicative as Applicative
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.Map.Strict as Map

import Language.Symantic.Lib.Control.Monad
import Language.Symantic.Type
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 $ \(Lambda f) a -> Repr_Host $ f $ return a
	inline f = return $ Lambda $      unRepr_Host . f . Repr_Host
	val    f = return $ Lambda $  (>>= unRepr_Host . f . Repr_Host  . return)
	lazy   f = return $ Lambda $ ((>>= unRepr_Host . f . Repr_Host) . lazy_share)
instance Monad lam => Sym_Bool (Repr_Host lam) where
	bool = return
	not  = Functor.fmap Bool.not
	(&&) = liftM2 (Prelude.&&)
	(||) = liftM2 (Prelude.||)
instance Monad lam => Sym_Int (Repr_Host lam) where
	int    = return
	abs    = Functor.fmap Prelude.abs
	negate = Functor.fmap Prelude.negate
	(+)    = liftM2 (Prelude.+)
	(-)    = liftM2 (Prelude.-)
	(*)    = liftM2 (Prelude.*)
	mod    = liftM2 Prelude.mod
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
	(==) = liftM2 (Prelude.==)
instance Monad lam => Sym_Ord (Repr_Host lam) where
	compare = liftM2 Prelude.compare
instance Monad lam => Sym_List (Repr_Host lam) where
	list_empty = return []
	list_cons  = liftM2 (:)
	list       = sequence
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 :) Prelude.<$>) 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 = Functor.fmap Map.fromList
instance MonadIO lam => Sym_Map_Lam lam (Repr_Host lam) where
	map_map f = liftMJoin $ sequence . ((\a -> f `app` return a) Prelude.<$>)
instance MonadIO lam => Sym_Functor lam (Repr_Host lam) where
	fmap f = liftMJoin $ sequence . ((\a -> f `app` return a) Prelude.<$>)
instance Monad lam => Sym_Applicative (Repr_Host lam) where
	pure = Functor.fmap Applicative.pure
instance MonadIO lam => Sym_Applicative_Lam lam (Repr_Host lam) where
	(<*>) = liftM2Join $ \fg fa ->
		Repr_Host $ sequence $
		 (unLambda Functor.<$> fg)
		 Applicative.<*>
		 (return Functor.<$> fa)

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