{-# 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 Data.Functor.Identity
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

type instance Lambda_from_Repr (Repr_Host lam) = lam
instance Monad lam => Sym_Lambda_App lam (Repr_Host lam) where
	app      = liftM2Join $ \(Lambda f) a -> Repr_Host $ f $ return a
instance Monad lam => Sym_Lambda_Inline lam (Repr_Host lam) where
	inline f = return $ Lambda $ unRepr_Host . f . Repr_Host
instance Monad lam => Sym_Lambda_Val lam (Repr_Host lam) where
	val    f = return $ Lambda $ (>>= unRepr_Host . f . Repr_Host  . return)
instance MonadIO lam => Sym_Lambda_Lazy lam (Repr_Host lam) where
	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 Monad 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 Monad 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 Monad lam => Sym_Map_Lam lam (Repr_Host lam) where
	map_map f = liftMJoin $ sequence . ((\a -> f `app` return a) Prelude.<$>)
instance Sym_Functor Identity (Repr_Host Identity) where
	fmap f m = (a2b Functor.<$>) Functor.<$> m
		where a2b a = runIdentity $ unRepr_Host $ f `app` return a
	{- NOTE: need Traversable
	fmap f = liftMJoin $ sequence . ((\a -> f `app` return a) Functor.<$>)
	-}
instance Monad lam => Sym_Applicative (Repr_Host lam) where
	pure = Functor.fmap Applicative.pure
instance Sym_Applicative_Lam Identity (Repr_Host Identity) where
	(<*>) = liftM2Join $ \fg ->
		return . (Applicative.<*>)
		 ((\(Lambda g) -> runIdentity . g . Identity) Functor.<$> fg)
	{- NOTE: need Traversable
	(<*>) = 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