{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- {-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Hcompta.Expr.Fun where

import Control.Monad (Monad(..))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bool
-- import Data.Either (Either(..))
-- import Data.Eq (Eq(..))
import Data.Function (($), (.), id)
import Data.IORef
-- import Data.Maybe (Maybe(..))
-- import Data.Monoid ((<>))
-- import Data.Proxy (Proxy(..))
-- import Data.String (String)
-- import Data.Type.Equality ((:~:)(Refl))
-- import Text.Show (Show(..))

import Hcompta.Expr.Dup

-- * Class 'Expr_Fun'

-- | /Tagless-final symantics/ for /lambda abstraction/
-- in /higher-order abstract syntax/ (HOAS),
-- and with argument @arg@ and result @res@ of functions @(->)@ inside 'repr',
-- wrapped into 'repr': to control the calling.
class Expr_Fun repr where
	default app        :: Monad   repr => repr (repr arg -> repr res) ->       repr arg -> repr res
	
	default inline     :: Monad   repr =>      (repr arg -> repr res) -> repr (repr arg -> repr res)
	default val        :: Monad   repr =>      (repr arg -> repr res) -> repr (repr arg -> repr res)
	default lazy       :: MonadIO repr =>      (repr arg -> repr res) -> repr (repr arg -> repr res)
	
	default let_inline :: Monad   repr => repr arg -> (repr arg -> repr res) -> repr res
	default let_val    :: Monad   repr => repr arg -> (repr arg -> repr res) -> repr res
	default let_lazy   :: MonadIO repr => repr arg -> (repr arg -> repr res) -> repr res
	
	app :: repr (repr arg -> repr res) -> repr arg -> repr res
	app x y = x >>= ($ y)
	
	-- | /call-by-name/ lambda
	inline :: (repr arg -> repr res) -> repr (repr arg -> repr res)
	inline = return
	-- | /call-by-value/ lambda
	val :: (repr arg -> repr res) -> repr (repr arg -> repr res)
	val f = return (>>= f . return)
	-- | /call-by-need/ lambda (aka. /lazyness/): lazy shares its argument, no matter what.
	lazy :: (repr arg -> repr res) -> repr (repr arg -> repr res)
	lazy f = return ((>>= f) . expr_fun_lazy_share)
	
	-- | Convenient 'inline' wrapper.
	let_inline :: repr arg -> (repr arg -> repr res) -> repr res
	let_inline x y = inline y `app` x
	-- | Convenient 'val' wrapper.
	let_val :: repr arg -> (repr arg -> repr res) -> repr res
	let_val x y = val y `app` x
	-- | Convenient 'lazy' wrapper.
	let_lazy :: repr arg -> (repr arg -> repr res) -> repr res
	let_lazy x y = lazy y `app` x
	
	ident :: repr a -> repr a
	ident = id

-- | Utility for storing arguments of 'lazy' into an 'IORef'.
expr_fun_lazy_share :: MonadIO m => m a -> m (m a)
expr_fun_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

instance -- Expr_Fun Dup
 ( Expr_Fun r1
 , Expr_Fun r2
 , Monad r1
 , Monad r2
 ) => Expr_Fun (Dup r1 r2) where
	app (r1_f `Dup` r2_f) (x1 `Dup` x2) =
		app (return $ \r1_a -> do
			f <- r1_f
			a <- r1_a
			dup1 $ f (r1_a `Dup` return a)) x1
		`Dup`
		app (return $ \r2_a -> do
			f <- r2_f
			a <- r2_a
			dup2 $ f (return a `Dup` r2_a)) x2
	inline f = dup1 (inline f) `Dup` dup2 (inline f)
	val    f = dup1 (val f)    `Dup` dup2 (val f)
	lazy   f = dup1 (lazy f)   `Dup` dup2 (lazy f)
	let_inline (x1 `Dup` x2) in_ =
		let_inline x1 (\r1_a -> do
			a <- r1_a
			dup1 $ in_ $ r1_a `Dup` return a)
		`Dup`
		let_inline x2 (\r2_a -> do
			a <- r2_a
			dup2 $ in_ $ return a `Dup` r2_a)
	let_val (x1 `Dup` x2) in_ =
		let_val x1 (\r1_a -> do
			a <- r1_a
			dup1 $ in_ $ r1_a `Dup` return a)
		`Dup`
		let_val x2 (\r2_a -> do
			a <- r2_a
			dup2 $ in_ $ return a `Dup` r2_a)
	let_lazy (x1 `Dup` x2) in_ =
		let_lazy x1 (\r1_a -> do
			a <- r1_a
			dup1 $ in_ $ r1_a `Dup` return a)
		`Dup`
		let_lazy x2 (\r2_a -> do
			a <- r2_a
			dup2 $ in_ $ return a `Dup` r2_a)