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

import Data.Bool (Bool)
import Data.Char (Char)
import Data.Eq (Eq)
import Data.Functor.Identity (Identity(..))
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 (app :: * -> *) where
  runtime :: Unlift app a -> app a
  (.)   :: app ((b->c) -> (a->b) -> a -> c)
  ($)   :: app ((a->b) -> a -> b)
  (.@)  :: app (a->b) -> app a -> app b
  bool  :: Bool -> app Bool
  char  :: Char -> app Char
  cons  :: app (a -> [a] -> [a])
  const :: app (a -> b -> a)
  eq    :: Eq a => app a -> app (a -> Bool)
  flip  :: app ((a -> b -> c) -> b -> a -> c)
  id    :: app (a->a)
  nil   :: app [a]
  unit  :: app ()
instance Runtimeable Identity

-- ** Type 'Runtimeable'
-- | Initial encoding of 'Runtimeable'
data OptRuntime (app:: * -> *) a where
  OptRuntime :: app a -> OptRuntime app a
  (:.)  :: OptRuntime app ((b->c) -> (a->b) -> a -> c)
  (:$)  :: OptRuntime app ((a->b) -> a -> b)
  (:@)  :: OptRuntime app (a->b) -> OptRuntime app a -> OptRuntime app b
  Const :: OptRuntime app (a -> b -> a)
  Flip  :: OptRuntime app ((a -> b -> c) -> b -> a -> c)
  Id    :: OptRuntime app (a->a)
type instance Unlift (OptRuntime app) = app
instance (Liftable app, Unliftable app, Runtimeable app) => Liftable (OptRuntime app) where
  lift = OptRuntime
instance (Unliftable app, Runtimeable app) => Unliftable (OptRuntime app) 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 app) 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))
  bool b   = Runtime (bool b) (bool b)
  char c   = Runtime (char c) (char c)
  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))
  bool     = Eval
  char     = Eval
  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) ||]
  bool b   = Code [|| b ||]
  char c   = Code [|| c ||]
  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 [|| () ||]