{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | This module provides the 'Identity' and 'IdentityT' semantics
-- which interprets the combinators as a Haskell value.
module Symantic.Semantics.Identity (
  Identity (..),
  IdentityT (..),
) where

import Control.Applicative qualified as App
import Control.Monad.Trans.Identity (IdentityT (..))
import Data.Either qualified as Either
import Data.Eq qualified as Eq
import Data.Function qualified as Fun
import Data.Functor.Identity (Identity (..))
import Data.Maybe qualified as Maybe

import Debug.Trace (traceShow)
import Text.Show (Show)

import Symantic.Syntaxes.Classes
import Symantic.Syntaxes.Derive

-- * Type 'IdentityT'

type instance Derived (IdentityT sem) = sem
instance Derivable (IdentityT sem) where
  derive = runIdentityT
instance LiftDerived (IdentityT sem) where
  liftDerived = IdentityT
instance LiftDerived1 (IdentityT sem) where
  liftDerived1 f = IdentityT Fun.. f Fun.. runIdentityT
instance LiftDerived2 (IdentityT sem) where
  liftDerived2 f x y = IdentityT (f (runIdentityT x) (runIdentityT y))
instance LiftDerived3 (IdentityT sem) where
  liftDerived3 f x y z = IdentityT (f (runIdentityT x) (runIdentityT y) (runIdentityT z))
instance LiftDerived4 (IdentityT sem) where
  liftDerived4 f w x y z = IdentityT (f (runIdentityT w) (runIdentityT x) (runIdentityT y) (runIdentityT z))

instance Abstractable sem => Abstractable (IdentityT sem)
instance Abstractable1 sem => Abstractable1 (IdentityT sem)
instance Anythingable sem => Anythingable (IdentityT sem)
instance Constantable c sem => Constantable c (IdentityT sem)
instance Eitherable sem => Eitherable (IdentityT sem)
instance Equalable sem => Equalable (IdentityT sem)
instance IfThenElseable sem => IfThenElseable (IdentityT sem)
instance Instantiable sem => Instantiable (IdentityT sem)
instance LetRecable idx sem => LetRecable idx (IdentityT sem)
instance Listable sem => Listable (IdentityT sem)
instance Maybeable sem => Maybeable (IdentityT sem)
instance Unabstractable sem => Unabstractable (IdentityT sem)
instance Varable sem => Varable (IdentityT sem)

-- * Type 'Identity'
instance Abstractable Identity where
  lam f = Identity (runIdentity Fun.. f Fun.. Identity)
instance Abstractable1 Identity where
  lam1 f = Identity (runIdentity Fun.. f Fun.. Identity)
instance Anythingable Identity
instance Constantable c Identity where
  constant = Identity
instance Eitherable Identity where
  either = Identity Either.either
  left = Identity Either.Left
  right = Identity Either.Right
instance Equalable Identity where
  equal = Identity (Eq.==)
instance IfThenElseable Identity where
  ifThenElse test ok ko =
    Identity
      ( if runIdentity test
          then runIdentity ok
          else runIdentity ko
      )
instance Instantiable Identity where
  Identity f .@ Identity x = Identity (f x)
instance Listable Identity where
  cons = Identity (:)
  nil = Identity []
instance Maybeable Identity where
  nothing = Identity Maybe.Nothing
  just = Identity Maybe.Just
instance Unabstractable Identity where
  ap = Identity (App.<*>)
  const = Identity Fun.const
  id = Identity Fun.id
  (.) = Identity (Fun..)
  flip = Identity Fun.flip
  ($) = Identity (Fun.$)
instance Varable Identity where
  var = Fun.id
instance Letable Identity where
  let_ e body = body e
instance Show idx => LetRecable idx Identity where
  letRec _idx f body =
    Identity Fun.$
      -- traceShow ["Identity", "letRec"] Fun.$
      let self idx =
            -- traceShow (["Identity", "letRec", "self"], ("idx", idx)) Fun.$
            runIdentity (f (Identity Fun.. self) idx)
      in runIdentity (body (Identity Fun.. self))