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

import Control.Applicative as Applicative
import Control.Monad as Monad
import Control.Monad.IO.Class (MonadIO(..))
import Data.Functor as Functor
import Data.Functor.Identity
import Data.IORef
import Data.Traversable as Traversable
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 hiding (Sym_Monad(..), Sym_Monad_Lam(..))
import qualified Language.Symantic.Expr as 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
 ( Sym_Applicative_Lam lam (Repr_Host lam)
 , Applicative 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)
	-}
instance Sym_Traversable Identity (Repr_Host Identity) where
	traverse ra2fb = liftMJoin $
		return . Traversable.traverse a2fb
		where a2fb a = runIdentity $ unRepr_Host $ ra2fb `app` return a
instance
 ( Expr.Sym_Monad_Lam lam (Repr_Host lam)
 , Monad lam
 ) => Expr.Sym_Monad (Repr_Host lam) where
	return = Functor.fmap Monad.return
instance Expr.Sym_Monad_Lam Identity (Repr_Host Identity) where
	(>>=) rma ra2mb = do
		ma <- rma
		return $ (Monad.>>=) ma a2mb
		where a2mb a = runIdentity $ unRepr_Host $ ra2mb `app` return a

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