Algebrable.hs

module Symantic.Base.Algebrable where

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

import Symantic.Base.ADT
import Symantic.Base.CurryN
import Symantic.Base.Composable

-- | @('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
  default (<:>) :: Transformable repr => Tupable (UnTrans repr) =>
           repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k
  (<:>) :: repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k
  (<:>) = trans2 (<:>)
infixr 4 <:>

-- ** Class 'Unitable'
class Unitable repr where
  default unit :: Transformable repr => Unitable (UnTrans repr) =>
          repr (() -> k) k
  unit :: repr (() -> k) k
  unit = noTrans unit

-- ** Class 'Constant'
class Constant repr where
  default constant :: Transformable repr => Constant (UnTrans repr) =>
              a -> repr (a -> k) k
  constant :: a -> repr (a -> k) k
  constant = noTrans . constant

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

-- ** Class 'Emptyable'
class Emptyable repr where
  default empty :: Transformable repr => Emptyable (UnTrans repr) =>
           repr k k
  empty :: repr k k
  empty = noTrans empty

-- ** Class 'Optionable'
class Optionable repr where
  default option :: Transformable repr => Optionable (UnTrans repr) =>
            repr k k -> repr k k
  option :: repr k k -> repr k k
  option = trans1 option
  default optional :: Transformable repr => Optionable (UnTrans repr) =>
              repr (a->k) k -> repr (Maybe a->k) k
  optional :: repr (a->k) k -> repr (Maybe a->k) k
  optional = trans1 optional

-- * Class 'Repeatable'
class Repeatable repr where
  default many0 :: Transformable repr => Repeatable (UnTrans repr) =>
           repr (a->k) k -> repr ([a]->k) k
  many0 :: repr (a->k) k -> repr ([a]->k) k
  many0 = trans1 many0
  default many1 :: Transformable repr => Repeatable (UnTrans repr) =>
           repr (a->k) k -> repr ([a]->k) k
  many1 :: repr (a->k) k -> repr ([a]->k) k
  many1 = trans1 many1

-- * Class 'Substractable'
class Substractable repr where
  default (<->) :: Transformable repr => Substractable (UnTrans repr) =>
           repr a k -> repr k' k' -> repr a k
  (<->) :: repr a k -> repr k' k' -> repr a k
  (<->) = trans2 (<->)
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
  default dicurry ::
   Transformable repr =>
   Dicurryable (UnTrans repr) =>
   CurryN args =>
   proxy args ->
   (args-..->r) ->
   (r->Tuples args) ->
   repr (args-..->k) k ->
   repr (r->k) k
  dicurry args constr destr = trans1 (dicurry args constr destr)

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