module Symantic.Dityped.Algebrable where

import Data.Either (Either)
import Data.Function ((.))
import Data.Maybe (Maybe(..))
import Data.Proxy (Proxy(..))
import GHC.Generics (Generic)

import Symantic.Utils.ADT
import Symantic.Utils.CurryN
import Symantic.Dityped.Composable
import Symantic.Dityped.Transformable

-- | @('adt' @@SomeADT some_expr)@
-- wrap\/unwrap @(some_expr)@ input\/output value
-- to\/from the Algebraic Data Type @(SomeADT)@.
-- @(SomeADT)@ must have a 'Generic' instance
-- (using the @DeriveGeneric@ language extension to GHC).
adt ::
 forall adt repr k.
 Dimapable repr =>
 Generic adt =>
 RepOfEoT adt =>
 EoTOfRep adt =>
 repr (EoT (ADT adt) -> k) k ->
 repr (adt -> k) k
adt = dimap adtOfeot eotOfadt

-- * Class 'Tupable'
class Tupable repr where
  (<:>) :: repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k
  (<:>) = lift2 (<:>)
  default (<:>) ::
    Liftable2 repr => Tupable (Unlifted repr) =>
    repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k
infixr 4 <:>

-- ** Class 'Unitable'
class Unitable repr where
  unit :: repr (() -> k) k
  unit = lift unit
  default
    unit :: Liftable repr => Unitable (Unlifted repr) =>
    repr (() -> k) k

-- ** Class 'Constant'
class Constant repr where
  constant :: a -> repr (a -> k) k
  constant = lift . constant
  default constant ::
    Liftable repr => Constant (Unlifted repr) =>
    a -> repr (a -> k) k

-- * Class 'Eitherable'
class Eitherable repr where
  (<+>) :: repr (a->k) k -> repr (b->k) k -> repr (Either a b->k) k
  (<+>) = lift2 (<+>)
  default (<+>) ::
    Liftable2 repr => Eitherable (Unlifted repr) =>
    repr (a->k) k -> repr (b->k) k -> repr (Either a b -> k) k
-- NOTE: yes infixr, not infixl like <|>,
-- in order to run left-most checks first.
infixr 3 <+>

-- ** Class 'Emptyable'
class Emptyable repr where
  empty :: repr k k
  empty = lift empty
  default empty ::
    Liftable repr => Emptyable (Unlifted repr) =>
    repr k k

-- ** Class 'Optionable'
class Optionable repr where
  option :: repr k k -> repr k k
  option = lift1 option
  default option ::
    Liftable1 repr => Optionable (Unlifted repr) =>
    repr k k -> repr k k
  optional :: repr (a->k) k -> repr (Maybe a->k) k
  optional = lift1 optional
  default optional ::
    Liftable1 repr => Optionable (Unlifted repr) =>
    repr (a->k) k -> repr (Maybe a->k) k

-- * Class 'Repeatable'
class Repeatable repr where
  many0 :: repr (a->k) k -> repr ([a]->k) k
  many0 = lift1 many0
  default many0 ::
    Liftable1 repr => Repeatable (Unlifted repr) =>
    repr (a->k) k -> repr ([a]->k) k
  many1 :: repr (a->k) k -> repr ([a]->k) k
  many1 = lift1 many1
  default many1 ::
    Liftable1 repr => Repeatable (Unlifted repr) =>
    repr (a->k) k -> repr ([a]->k) k

-- * Class 'Substractable'
class Substractable repr where
  (<->) :: repr a k -> repr k' k' -> repr a k
  (<->) = lift2 (<->)
  default (<->) ::
    Liftable2 repr => Substractable (Unlifted repr) =>
    repr a k -> repr k' k' -> repr a k
infixr 3 <->

-- * Class 'Dicurryable'
class Dicurryable repr where
  dicurry ::
    CurryN args =>
    proxy args ->
    (args-..->r) -> -- construction
    (r->Tuples args) -> -- destruction
    repr (args-..->k) k ->
    repr (r->k) k
  dicurry args constr destr = lift1 (dicurry args constr destr)
  default dicurry ::
    Liftable1 repr =>
    Dicurryable (Unlifted repr) =>
    CurryN args =>
    proxy args ->
    (args-..->r) ->
    (r->Tuples args) ->
    repr (args-..->k) k ->
    repr (r->k) k

construct ::
  forall args a k repr.
  Dicurryable repr =>
  Generic a =>
  EoTOfRep a =>
  CurryN args =>
  Tuples args ~ EoT (ADT a) =>
  (args ~ Args (args-..->a)) =>
  (args-..->a) ->
  repr (args-..->k) k ->
  repr (a -> k) k
construct f = dicurry (Proxy::Proxy args) f eotOfadt