{-# LANGUAGE TemplateHaskell #-}
module Symantic.Parser.Staging where

import Data.Bool (Bool)
import Data.Char (Char)
import Data.Eq (Eq)
import Language.Haskell.TH (TExpQ)
import qualified Data.Eq as Eq
import qualified Data.Function as Function

import Symantic.Base.Univariant

-- * Type 'Runtime'
data Runtime a = Runtime
 { eval :: Eval a
   -- ^ The value of the runtime code,
   -- kept along to be made available to the optimizer.
 , code :: Code a
   -- ^ An AST of a runtime value.
 }
getEval :: Runtime a -> a
getEval = unEval Function.. eval
getCode :: Runtime a -> TExpQ a
getCode = unCode Function.. code
type instance Unlift Runtime = Runtime
instance Liftable Runtime where
  lift = Function.id
  {-# INLINE lift #-}
instance Unliftable Runtime where
  unlift = Function.id
  {-# INLINE unlift #-}

-- ** Type 'Eval'
newtype Eval a = Eval { unEval :: a }
type instance Unlift Eval = Eval
instance Liftable Eval where
  lift = Function.id
  {-# INLINE lift #-}
instance Unliftable Eval where
  unlift = Function.id
  {-# INLINE unlift #-}

-- ** Type 'Code'
newtype Code a = Code { unCode :: TExpQ a }
type instance Unlift Code = Code
instance Liftable Code where
  lift = Function.id
  {-# INLINE lift #-}
instance Unliftable Code where
  unlift = Function.id
  {-# INLINE unlift #-}

-- * Class 'Runtimeable'
-- | Final encoding of some Runtimeable functions
-- useful for some optimizations in 'optGram'.
class Runtimeable (repr :: * -> *) where
  runtime :: Unlift repr a -> repr a
  (.)   :: repr ((b->c) -> (a->b) -> a -> c)
  ($)   :: repr ((a->b) -> a -> b)
  (.@)  :: repr (a->b) -> repr a -> repr b
  --char  :: Char -> repr Char
  cons  :: repr (a -> [a] -> [a])
  const :: repr (a -> b -> a)
  eq    :: Eq a => repr a -> repr (a -> Bool)
  flip  :: repr ((a -> b -> c) -> b -> a -> c)
  id    :: repr (a->a)
  nil   :: repr [a]
  unit  :: repr ()

-- ** Type 'Runtimeable'
-- | Initial encoding of 'Runtimeable'
data OptRuntime (repr:: * -> *) a where
  OptRuntime :: repr a -> OptRuntime repr a
  (:.)  :: OptRuntime repr ((b->c) -> (a->b) -> a -> c)
  (:$)  :: OptRuntime repr ((a->b) -> a -> b)
  (:@)  :: OptRuntime repr (a->b) -> OptRuntime repr a -> OptRuntime repr b
  Const :: OptRuntime repr (a -> b -> a)
  Flip  :: OptRuntime repr ((a -> b -> c) -> b -> a -> c)
  Id    :: OptRuntime repr (a->a)
type instance Unlift (OptRuntime repr) = repr
instance (Liftable repr, Unliftable repr, Runtimeable repr) => Liftable (OptRuntime repr) where
  lift = OptRuntime
instance (Unliftable repr, Runtimeable repr) => Unliftable (OptRuntime repr) where
  unlift = \case
   OptRuntime x -> runtime (unlift x)
   (:.)     -> (.)
   (:$)     -> ($)
   (:@) f x -> (.@) (unlift f) (unlift x)
   Const    -> const
   Flip     -> flip
   Id       -> id
infixr 0 $, :$
infixr 9 ., :.
infixl 9 .@, :@

instance Runtimeable (OptRuntime repr) where
  runtime = OptRuntime
  (.)   = (:.)
  ($)   = (:$)
  (.@)  = (:@)
  const = Const
  flip  = Flip
  id    = Id
instance Runtimeable Runtime where
  runtime  = Function.id
  (.)      = Runtime (.) (.)
  ($)      = Runtime ($) ($)
  (.@) f x = Runtime ((.@) (eval f) (eval x)) ((.@) (code f) (code x))
  cons     = Runtime cons cons
  const    = Runtime const const
  eq x     = Runtime (eq (eval x)) (eq (code x))
  flip     = Runtime flip flip
  id       = Runtime id id
  nil      = Runtime nil nil
  unit     = Runtime unit unit
instance Runtimeable Eval where
  runtime  = lift
  (.)      = Eval (Function..)
  ($)      = Eval (Function.$)
  (.@) f x = Eval ((unEval f) (unEval x))
  cons     = Eval (:)
  const    = Eval Function.const
  eq x     = Eval (unEval x Eq.==)
  flip     = Eval Function.flip
  id       = Eval Function.id
  nil      = Eval []
  unit     = Eval ()
instance Runtimeable Code where
  runtime  = lift
  (.)      = Code [|| \f g x -> f (g x) ||]
  ($)      = Code [|| \f x -> f x ||]
  (.@) f x = Code [|| $$(unCode f) $$(unCode x) ||]
  cons     = Code [|| \x xs -> x : xs ||]
  const    = Code [|| \x _ -> x ||]
  eq x     = Code [|| \y -> $$(unCode x) Eq.== y ||]
  flip     = Code [|| \f x y -> f y x ||]
  id       = Code [|| \x -> x ||]
  nil      = Code [|| [] ||]
  unit     = Code [|| () ||]