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

import Data.Bool (Bool)
import Data.Char (Char)
import qualified Data.Function as Fun
import Data.Either (Either(..))
import Data.Eq (Eq)
import Data.Ord (Ord(..))
import Data.Functor (Functor(..))
import Data.Hashable (Hashable, hashWithSalt, hash)
import Data.Maybe (Maybe(..))
import GHC.Exts (Int(..))
import GHC.Prim (StableName#, unsafeCoerce#)
import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
import Language.Haskell.TH (TExpQ)
import System.IO (IO)
import Text.Show (Show(..), showParen, showString)
import qualified Data.Eq as Eq
import qualified Data.Function as Function

import Symantic.Base.Univariant

-- * Type 'ValueCode'
-- | Compile-time 'value' and corresponding 'code' (that can produce that value at runtime).
data ValueCode a = ValueCode
 { value :: Value a
 , code :: Code a
 }
getValue :: ValueCode a -> a
getValue = unValue Function.. value
getCode :: ValueCode a -> TExpQ a
getCode = unCode Function.. code
type instance Unlift ValueCode = ValueCode
instance Liftable ValueCode where
  lift = Function.id
  {-# INLINE lift #-}
instance Unliftable ValueCode where
  unlift = Function.id
  {-# INLINE unlift #-}

-- ** Type 'Value'
newtype Value a = Value { unValue :: a }
type instance Unlift Value = Value
instance Liftable Value where
  lift = Function.id
  {-# INLINE lift #-}
instance Unliftable Value 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 (repr :: * -> *) where
  haskell :: Unlift repr a -> repr a
  (.) :: repr ((b->c) -> (a->b) -> a -> c)
  ($) :: repr ((a->b) -> a -> b)
  (.@) :: repr (a->b) -> repr a -> repr b
  bool :: Bool -> repr Bool
  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 ()
  left :: repr (l -> Either l r)
  right :: repr (r -> Either l r)
  nothing :: repr (Maybe a)
  just :: repr (a -> Maybe a)
-- instance Haskellable Identity

-- ** Type 'Haskellable'
-- | Initial encoding of 'Haskellable'
data Haskell a where
  Haskell :: ValueCode a -> Haskell a
  (:.) :: Haskell ((b->c) -> (a->b) -> a -> c)
  (:$) :: Haskell ((a->b) -> a -> b)
  (:@) :: Haskell (a->b) -> Haskell a -> Haskell b
  Const :: Haskell (a -> b -> a)
  Flip :: Haskell ((a -> b -> c) -> b -> a -> c)
  Id :: Haskell (a->a)
instance Show (Haskell a) where
  showsPrec p = \case
   Haskell{} -> showString "Haskell"
   (:.) -> showString "(.)"
   (:$) -> showString "($)"
   (:@) f x ->
    showParen (p > 0)
    Fun.$ showString "(@) "
    Fun.. showsPrec 10 f
    Fun.. showString " "
    Fun.. showsPrec 10 x
   Const -> showString "const"
   Flip -> showString "flip"
   Id -> showString "id"
type instance Unlift Haskell = ValueCode
instance Liftable Haskell where
  lift = Haskell
instance Unliftable Haskell where
  unlift = \case
   Haskell x -> haskell x
   (:.) -> (.)
   (:$) -> ($)
   (:@) f x -> (.@) (unlift f) (unlift x)
   Const -> const
   Flip -> flip
   Id -> id
infixr 0 $, :$
infixr 9 ., :.
infixl 9 .@, :@

instance Haskellable Haskell where
  haskell = Haskell
  (.)     = (:.)
  ($)     = (:$)
  (.@)    = (:@)
  const   = Const
  flip    = Flip
  id      = Id
  unit    = Haskell unit
  left    = Haskell left
  right   = Haskell right
  nothing = Haskell nothing
  just    = Haskell just
instance Haskellable ValueCode where
  haskell  = Function.id
  (.)      = ValueCode (.) (.)
  ($)      = ValueCode ($) ($)
  (.@) f x = ValueCode ((.@) (value f) (value x)) ((.@) (code f) (code x))
  bool b   = ValueCode (bool b) (bool b)
  char c   = ValueCode (char c) (char c)
  cons     = ValueCode cons cons
  const    = ValueCode const const
  eq x     = ValueCode (eq (value x)) (eq (code x))
  flip     = ValueCode flip flip
  id       = ValueCode id id
  nil      = ValueCode nil nil
  unit     = ValueCode unit unit
  left     = ValueCode left left
  right    = ValueCode right right
  nothing  = ValueCode nothing nothing
  just     = ValueCode just just
instance Haskellable Value where
  haskell  = lift
  (.)      = Value (Function..)
  ($)      = Value (Function.$)
  (.@) f x = Value (unValue f (unValue x))
  bool     = Value
  char     = Value
  cons     = Value (:)
  const    = Value Function.const
  eq x     = Value (unValue x Eq.==)
  flip     = Value Function.flip
  id       = Value Function.id
  nil      = Value []
  unit     = Value ()
  left     = Value Left
  right    = Value Right
  nothing  = Value Nothing
  just     = Value Just
instance Haskellable Code where
  haskell  = 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 [|| () ||]
  left     = Code [|| Left ||]
  right    = Code [|| Right ||]
  nothing  = Code [|| Nothing ||]
  just     = Code [|| Just ||]