{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.Production where

import Control.Monad (Monad(..))
--import Data.Functor.Product (Product(..))
import Prelude (Num(..), undefined, error)
import Text.Show (Show(..), showString)
import Type.Reflection (Typeable)
import qualified Control.Applicative as App
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 qualified Language.Haskell.TH.Show as TH
import Data.Kind (Type)

import Symantic.Syntaxes.Classes
import Symantic.Semantics.Data
import Symantic.Semantics.Identity
import Symantic.Syntaxes.Derive

data Production (vs :: [Type]) a where
  -- TODO: move SomeData from Prod to here?
  ProdE :: Prod a -> Production vs a
  --ProdV :: Production (a ': vs) a
  --ProdN :: Production vs (a->b) -> Production (a ': vs) b
  --ProdW :: Production vs b -> Production (a ': vs) b

instance Show (Production '[] a) where
  showsPrec p x = showsPrec p (normalOrderReduction (prodCode x))
instance Show (SomeData TH.CodeQ a) where
  -- The 'Derivable' constraint contained in 'SomeData'
  -- is 'TH.CodeQ', hence 'Symantic.View' cannot be used here.
  -- Fortunately 'TH.showCode' can be implemented.
  showsPrec p = showString Fun.. TH.showCode p Fun.. derive



data Prod a = Prod
  { prodI :: SomeData Identity a
  , prodQ :: SomeData TH.CodeQ a
  }

appProd ::
  Production vs (a -> b) ->
  Production vs a ->
  Production vs b
--ProdE p `appProd` ProdN e = ProdN (ProdE ((.) .@ p) `appProd` e)
--ProdE p `appProd` ProdV = ProdN (ProdE p)
--ProdE p `appProd` ProdW e = ProdW (ProdE p `appProd` e)
ProdE p1 `appProd` ProdE p2 = ProdE (p1 .@ p2)
--ProdN e `appProd` ProdE p = ProdN (ProdE (flip .@ flip .@ p) `appProd` e)
--ProdN e `appProd` ProdV = ProdN (ProdE ap `appProd` e `appProd` ProdE id)
--ProdN e1 `appProd` ProdN e2 = ProdN (ProdE ap `appProd` e1 `appProd` e2)
--ProdN e1 `appProd` ProdW e2 = ProdN (ProdE flip `appProd` e1 `appProd` e2)
--ProdV `appProd` ProdE p = ProdN (ProdE (flip .@ id .@ p))
--ProdV `appProd` ProdN e = ProdN (ProdE (ap .@ id) `appProd` e)
--ProdV `appProd` ProdW e = ProdN (ProdE (flip .@ id) `appProd` e)
--ProdW e `appProd` ProdE p = ProdW (e `appProd` ProdE p)
--ProdW e `appProd` ProdV = ProdN e
--ProdW e1 `appProd` ProdN e2 = ProdN (ProdE (.) `appProd` e1 `appProd` e2)
--ProdW e1 `appProd` ProdW e2 = ProdW (e1 `appProd` e2)

-- data Production a where
--   Prod :: { prodI :: SomeData Identity a
--           , prodQ :: SomeData TH.CodeQ a
--           } -> Production a
--   ProdV :: Production a
--   ProdN :: Production a -> Production a
--   ProdW :: Production a -> Production a

{-# INLINE prodValue #-}
prodValue :: Production '[] a -> SomeData Identity a
prodValue (ProdE (Prod v _)) = v
{-# INLINE prodCode #-}
prodCode :: Production '[] a -> SomeData TH.CodeQ a
prodCode (ProdE (Prod _ c)) = c

{-# INLINE production #-}
production :: a -> TH.CodeQ a -> Production vs a
production v c = ProdE (Prod
  (SomeData (Var (Identity v)))
  (SomeData (Var c)))

{-# INLINE prod #-}
prod :: TH.Lift a => a -> Production vs a
prod x = production x [||x||]

{-# INLINE runValue #-}
runValue :: Production '[] a -> a
runValue (ProdE (Prod v _c)) = runIdentity (derive v)
{-# INLINE runCode #-}
runCode :: Production '[] a -> TH.CodeQ a
runCode (ProdE (Prod _v c)) = derive c

-- Missing instances in 'Language.Haskell.TH',
-- needed for 'prodCon'.
deriving instance TH.Lift TH.OccName
deriving instance TH.Lift TH.NameFlavour
deriving instance TH.Lift TH.ModName
deriving instance TH.Lift TH.PkgName
deriving instance TH.Lift TH.NameSpace
deriving instance TH.Lift TH.Name

-- | @$(prodCon 'SomeConstructor)@ generates the 'Production' for @SomeConstructor@.
prodCon :: TH.Name -> TH.Q TH.Exp
prodCon name = do
  info <- TH.reify name
  case info of
    TH.DataConI n _ty _pn ->
      [| production $(return (TH.ConE n))
           (TH.unsafeCodeCoerce (return (TH.ConE $(TH.lift n)))) |]
    _ -> error "[BUG]: impossible prodCon case"

unProdE :: Production '[] a -> Prod a
unProdE t = case t of ProdE t' -> t'

instance Abstractable (Production '[]) where
  lam f = ProdE (lam (unProdE Fun.. f Fun.. ProdE))
instance Abstractable1 (Production '[]) where
  lam1 f = ProdE (lam1 (unProdE Fun.. f Fun.. ProdE))
instance Abstractable Prod where
  -- Those 'undefined' are not unreachables by 'f'
  -- but this is the cost to pay for defining this instance.
  -- In particular, 'f' must not define the 'TH.CodeQ' part
  -- using the 'Identity' part.
  lam f = Prod
    (lam (\x -> let Prod fx _ = f (Prod x undefined) in fx))
    (lam (\y -> let Prod _ fy = f (Prod undefined y) in fy))
instance Abstractable1 Prod where
  lam1 f = Prod
    (lam1 (\x -> let Prod fx _ = f (Prod x undefined) in fx))
    (lam1 (\y -> let Prod _ fy = f (Prod undefined y) in fy))
instance Instantiable (Production vs) where
  (.@) = appProd
instance Instantiable Prod where
  Prod f1 f2 .@ Prod x1 x2 = Prod (f1 .@ x1) (f2 .@ x2)
instance Varable Prod where
  var = Fun.id
instance Unabstractable (Production vs) where
  ap = ProdE ap
  const = ProdE const
  id = ProdE id
  (.) = ProdE (.)
  flip = ProdE flip
  ($) = ProdE ($)
instance Unabstractable Prod where
  ap = Prod ap ap
  const = Prod const const
  id = Prod id id
  flip = Prod flip flip
  (.) = Prod (.) (.)
  ($) = Prod ($) ($)
instance (Num (SomeData Identity a), Num (SomeData TH.CodeQ a)) => Num (Prod a) where
  Prod x1 x2 + Prod y1 y2 = Prod (x1 + y1) (x2 + y2)
  Prod x1 x2 * Prod y1 y2 = Prod (x1 * y1) (x2 * y2)
  Prod x1 x2 - Prod y1 y2 = Prod (x1 - y1) (x2 - y2)
  abs (Prod x1 x2) = Prod (abs x1) (abs x2)
  fromInteger i = Prod (fromInteger i) (fromInteger i)
  negate (Prod x1 x2) = Prod (negate x1) (negate x2)
  signum (Prod x1 x2) = Prod (signum x1) (signum x2)
instance Eitherable (Production vs) where
  either = ProdE either
  left = ProdE left
  right = ProdE right
instance Eitherable Prod where
  either = Prod either either
  left = Prod left left
  right = Prod right right
instance (TH.Lift c, Typeable c) => Constantable c (Production vs) where
  constant c = ProdE (constant c)
instance (TH.Lift c, Typeable c) => Constantable c Prod where
  constant c = Prod (constant c) (constant c)
instance (Inferable a (SomeData Identity), Inferable a (SomeData TH.CodeQ)) => Inferable a (Production vs) where
  infer = ProdE infer
instance (Inferable a (SomeData Identity), Inferable a (SomeData TH.CodeQ)) => Inferable a Prod where
  infer = Prod infer infer
instance Maybeable (Production vs) where
  nothing = ProdE nothing
  just = ProdE just
instance Maybeable Prod where
  nothing = Prod nothing nothing
  just = Prod just just
instance Listable (Production vs) where
  nil = ProdE nil
  cons = ProdE cons
instance Listable Prod where
  nil = Prod nil nil
  cons = Prod cons cons
instance Equalable (Production vs) where
  equal = ProdE equal
instance Equalable Prod where
  equal = Prod equal equal
instance Inferable () (SomeData Identity) where
  infer = constant ()
instance Inferable () (SomeData TH.CodeQ) where
  infer = constant ()

-- TH.CodeQ
instance Anythingable TH.CodeQ
instance Abstractable TH.CodeQ where
  lam f = [|| \x -> $$(f [||x||]) ||]
instance Instantiable TH.CodeQ where
  f .@ x = [|| $$f $$x ||]
instance Abstractable1 TH.CodeQ where
  lam1 f = [|| \u -> $$(f [||u||]) ||]
instance Varable TH.CodeQ where
  var = Fun.id
instance Unabstractable TH.CodeQ where
  ap = [|| (App.<*>) ||]
  id = [|| Fun.id ||]
  const = [|| Fun.const ||]
  flip = [|| Fun.flip ||]
  ($) = [|| (Fun.$) ||]
  (.) = [|| (Fun..) ||]
instance TH.Lift c => Constantable c TH.CodeQ where
  constant c = [|| c ||]
instance Eitherable TH.CodeQ where
  either = [|| Either.either ||]
  left = [|| Either.Left ||]
  right = [|| Either.Right ||]
instance Equalable TH.CodeQ where
  equal = [|| (Eq.==) ||]
instance IfThenElseable TH.CodeQ where
  ifThenElse test ok ko = [|| if $$test then $$ok else $$ko ||]
instance Listable TH.CodeQ where
  cons = [|| (:) ||]
  nil = [|| [] ||]
instance Maybeable TH.CodeQ where
  nothing = [|| Maybe.Nothing ||]
  just = [|| Maybe.Just ||]
instance Num a => Num (TH.CodeQ a) where
  x + y = [|| $$x + $$y||]
  x * y = [|| $$x * $$y||]
  x - y = [|| $$x - $$y||]
  abs x = [|| abs $$x ||]
  fromInteger i = [|| fromInteger $$(TH.liftTyped i) ||]
  negate x = [|| negate $$x ||]
  signum x = [|| signum $$x ||]