{-# 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 'Haskellable'
-- | Final encoding of some Haskellable functions
-- useful for some optimizations in 'optGram'.
class Haskellable (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 Haskellable Identity

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

instance Haskellable (Haskell app) where
  runtime = Haskell
  (.)   = (:.)
  ($)   = (:$)
  (.@)  = (:@)
  const = Const
  flip  = Flip
  id    = Id
instance Haskellable 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 Haskellable 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 Haskellable 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 [|| () ||]