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

import Data.Bool (Bool)
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Language.Haskell.TH (TExpQ)
import Text.Show (Show(..), showParen, showString)
import qualified Data.Eq as Eq
import qualified Data.Function as Fun
import qualified Data.Function as Function

import Symantic.Univariant.Trans

-- * 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 'Value'
newtype Value a = Value { unValue :: a }

-- ** Type 'Code'
newtype Code a = Code { unCode :: TExpQ a }

-- * Class 'Haskellable'
-- | Final encoding of some Haskell functions
-- useful for some optimizations in 'optimizeComb'.
class Haskellable (repr :: * -> *) where
  (.) :: 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)

-- ** 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)
  Unit :: Haskell ()
infixr 0 $, :$
infixr 9 ., :.
infixl 9 .@, :@
instance Show (Haskell a) where
  showsPrec p = \case
    Haskell{} -> showString "Haskell"
    (:.) -> showString "(.)"
    (:$) -> showString "($)"
    (:@) ((:.) :@ f) g ->
      showParen (p >= 9)
      Fun.$ showsPrec 9 f
      Fun.. showString " . "
      Fun.. showsPrec 9 g
    (:@) f x ->
      showParen (p >= 10)
      Fun.$ showsPrec 10 f
      Fun.. showString " "
      Fun.. showsPrec 10 x
    Const -> showString "const"
    Flip -> showString "flip"
    Id -> showString "id"
    Unit -> showString "()"
instance Trans Haskell ValueCode where
  trans = \case
    Haskell x -> x
    (:.) -> (.)
    (:$) -> ($)
    (:@) f x -> (.@) (trans f) (trans x)
    Const -> const
    Flip -> flip
    Id -> id
    Unit -> unit
instance Trans ValueCode Haskell where
  trans = Haskell
type instance Output Haskell = ValueCode

instance Haskellable Haskell where
  (.)     = (:.)
  ($)     = (:$)
  -- Small optimizations, mainly to reduce dump sizes.
  Id .@ x = x
  (Const :@ x) .@ _y = x
  ((Flip :@ Const) :@ _x) .@ y = y
  f .@ x  = f :@ x
  const   = Const
  flip    = Flip
  id      = Id
  unit    = Unit
  bool b  = Haskell (bool b)
  char c  = Haskell (char c)
  eq x    = Haskell (eq (trans x))
  cons    = Haskell cons
  nil     = Haskell nil
  left    = Haskell left
  right   = Haskell right
  nothing = Haskell nothing
  just    = Haskell just
instance Haskellable ValueCode where
  (.)      = 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
  (.)      = 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
  (.)      = 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 ||]