{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Parser.Grammar.Production where

import Data.Bool (Bool(..))
import Data.Char (Char)
import Data.Eq (Eq)
import Data.Functor.Identity (Identity(..))
import Prelude (undefined)
import Text.Show (Show(..), showString)
import qualified Data.Either as Either
import qualified Data.Eq as Eq
import qualified Data.Function as Fun
import qualified Data.Maybe as Maybe
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import Type.Reflection (Typeable)

import Symantic.Univariant.Data
import Symantic.Univariant.Lang
import Symantic.Univariant.Optim
import Symantic.Univariant.Trans
import Symantic.Univariant.View

import Debug.Trace

-- * Type 'Production'
data Production a
  = Production
  { prodValue :: SomeData Identity a
  , prodCode :: SomeData TH.CodeQ a
  --, prodView :: SomeData View a
  }

production :: a -> TH.CodeQ a -> Production a
production v c = Production
  { prodValue = SomeData (Var (Identity v))
  , prodCode = SomeData (Var c)
  }

prod :: TH.Lift a => a -> Production a
prod x = production x [||x||]

runValue :: Production a -> a
runValue x = runIdentity (trans x)
runCode :: Production a -> TH.CodeQ a
runCode = trans

instance Trans Production Identity where
  trans Production{prodValue = SomeData x} = trans x
instance Trans Production TH.CodeQ where
  trans Production{prodCode = SomeData x} = trans x

instance Abstractable Production where
  var = Fun.id
  f .@ x = Production
    { prodValue = prodValue f .@ prodValue x
    , prodCode = prodCode f .@ prodCode x
    }
  lam f = Production
    { prodValue = lam (\x -> prodValue (f Production{prodValue = x}))
    , prodCode = lam (\x -> prodCode (f Production{prodCode = x}))
    }
  lam1 f = Production
    { prodValue = lam1 (\x -> prodValue (f Production{prodValue = x}))
    , prodCode = lam1 (\x -> prodCode (f Production{prodCode = x}))
    }
  const = Production const const
  ($) = Production ($) ($)
  (.) = Production (.) (.)
  flip = Production flip flip
  id = Production id id
instance Eitherable Production where
  left = Production left left
  right = Production right right
instance (TH.Lift c, Typeable c) => Constantable c Production where
  constant c = Production (constant c) (constant c)
instance Maybeable Production where
  nothing = Production nothing nothing
  just = Production just just
instance Listable Production where
  nil = Production nil nil
  cons = Production cons cons
instance Equalable Production where
  equal = Production equal equal

optimizeProduction :: Production a -> Production a
optimizeProduction p = Production
  { prodValue = normalOrderReduction (prodValue p)
  , prodCode = normalOrderReduction (prodCode p)
  }

{-
class Tokenable repr where
  token :: tok -> repr tok
  default token ::
    Liftable repr => Tokenable (Output repr) =>
    tok -> repr tok
  token = lift Fun.. token

instance Show (SomeData ValueCode a) where
  showsPrec p (SomeData x) = showsPrec p (trans @_ @View x)
-}

{-
-- * Type 'ValueCode'
data ValueCode a = ValueCode
  { value :: a
  , code :: TH.CodeQ a
  }
instance Trans ValueCode ValueCode where
  trans = Fun.id
instance Abstractable ValueCode where
  f .@ x = ValueCode
    { value = runIdentity (Identity (value f) .@ (Identity (value x)))
    , code = code f .@ code x
    }
  lam f = ValueCode
    { value = runIdentity (lam (Identity Fun.. value Fun.. f Fun.. (`ValueCode` undefined) Fun.. runIdentity))
    , code = lam (code Fun.. f Fun.. ValueCode undefined)
    }
  lam1 = lam
  const = ValueCode (runIdentity const) const
  flip = ValueCode (runIdentity flip) flip
  id = ValueCode (runIdentity id) id
  ($) = ValueCode (runIdentity ($)) ($)
  (.) = ValueCode (runIdentity (.)) (.)
instance Anythingable ValueCode
instance TH.Lift c => Constantable c ValueCode where
  constant c = ValueCode (runIdentity (constant c)) (constant c)
instance Listable ValueCode where
  cons = ValueCode (runIdentity cons) cons
  nil = ValueCode (runIdentity nil) nil
instance Equalable ValueCode where
  equal = ValueCode (runIdentity equal) equal
instance Eitherable ValueCode where
  left = ValueCode (runIdentity left) left
  right = ValueCode (runIdentity right) right
instance Maybeable ValueCode where
  nothing = ValueCode (runIdentity nothing) nothing
  just = ValueCode (runIdentity just) just
-}

-- Identity
instance Anythingable Identity
instance Abstractable Identity where
  f .@ x = Identity (runIdentity f (runIdentity x))
  lam f = Identity (runIdentity Fun.. f Fun.. Identity)
  lam1 = lam
  var = Fun.id
  const = Identity Fun.const
  flip = Identity Fun.flip
  id = Identity Fun.id
  ($) = Identity (Fun.$)
  (.) = Identity (Fun..)
instance Constantable c Identity where
  constant = Identity
instance Eitherable Identity where
  left = Identity Either.Left
  right = Identity Either.Right
instance Equalable Identity where
  equal = Identity (Eq.==)
instance Listable Identity where
  cons = Identity (:)
  nil = Identity []
instance Maybeable Identity where
  nothing = Identity Maybe.Nothing
  just = Identity Maybe.Just

-- TH.CodeQ
instance Anythingable TH.CodeQ
instance Abstractable TH.CodeQ where
  (.@) f x = [|| $$f $$x ||]
  lam f = [|| \x -> $$(f [||x||]) ||]
  lam1 = lam
  var = Fun.id
  id = [|| \x -> x ||]
  const = [|| Fun.const ||]
  flip = [|| \f x y -> f y x ||]
  ($) = [|| (Fun.$) ||]
  (.) = [|| (Fun..) ||]
instance TH.Lift c => Constantable c TH.CodeQ where
  constant c = [|| c ||]
instance Eitherable TH.CodeQ where
  left = [|| Either.Left ||]
  right = [|| Either.Right ||]
instance Equalable TH.CodeQ where
  equal = [|| (Eq.==) ||]
instance Listable TH.CodeQ where
  cons = [|| (:) ||]
  nil = [|| [] ||]
instance Maybeable TH.CodeQ where
  nothing = [|| Maybe.Nothing ||]
  just = [|| Maybe.Just ||]