symantic-base-0.1.0.20210703: src/Symantic/Dityped/Lang.hs

{-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation
{-# LANGUAGE UndecidableInstances #-} -- For Permutation
module Symantic.Dityped.Lang where

import Data.Either (Either)
import Data.Eq (Eq)
import Data.Function ((.))
import Data.Maybe (Maybe(..), fromJust)
import Data.Proxy (Proxy(..))
import GHC.Generics (Generic)
import Text.Show (Show)

import Symantic.Dityped.ADT
import Symantic.Dityped.CurryN
import Symantic.Dityped.Derive

-- * Class 'Composable'
class Composable repr where
  (<.>) :: repr a b -> repr b c -> repr a c
  (<.>) = liftDerived2 (<.>)
  default (<.>) ::
    FromDerived2 Composable repr =>
    repr a b -> repr b c -> repr a c
infixr 4 <.>

-- ** Class 'Constant'
class Constant repr where
  constant :: a -> repr (a -> k) k
  constant = liftDerived . constant
  default constant ::
    FromDerived Constant repr =>
    a -> repr (a -> k) k

-- * 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 = liftDerived1 (dicurry args constr destr)
  default dicurry ::
    FromDerived1 Dicurryable 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

-- * Class 'Dimapable'
class Dimapable repr where
  dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
  dimap a2b b2a = liftDerived1 (dimap a2b b2a)
  default dimap ::
    FromDerived1 Dimapable repr =>
    (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k

-- * Class 'Eitherable'
class Eitherable repr where
  (<+>) :: repr (a->k) k -> repr (b->k) k -> repr (Either a b->k) k
  (<+>) = liftDerived2 (<+>)
  default (<+>) ::
    FromDerived2 Eitherable 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 <+>

-- | @('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 'Emptyable'
class Emptyable repr where
  empty :: repr k k
  empty = liftDerived empty
  default empty ::
    FromDerived Emptyable repr =>
    repr k k

-- ** Class 'Optionable'
class Optionable repr where
  option :: repr k k -> repr k k
  optional :: repr (a->k) k -> repr (Maybe a->k) k
  option = liftDerived1 option
  optional = liftDerived1 optional
  default option ::
    FromDerived1 Optionable repr =>
    repr k k -> repr k k
  default optional ::
    FromDerived1 Optionable repr =>
    repr (a->k) k -> repr (Maybe a->k) k

-- * Class 'Permutable'
class Permutable repr where
  -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
  type Permutation (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
  type Permutation repr = Permutation (Derived repr)
  permutable :: Permutation repr (a->k) k -> repr (a->k) k
  perm :: repr (a->k) k -> Permutation repr (a->k) k
  noPerm :: Permutation repr k k
  permWithDefault :: a -> repr (a->k) k -> Permutation repr (a->k) k
  optionalPerm ::
    Eitherable repr => Dimapable repr => Permutable repr =>
    repr (a->k) k -> Permutation repr (Maybe a -> k) k
  optionalPerm = permWithDefault Nothing . dimap Just fromJust

(<&>) ::
  Permutable repr =>
  Tupable (Permutation repr) =>
  repr (a->k) k ->
  Permutation repr (b->k) k ->
  Permutation repr ((a,b)->k) k
x <&> y = perm x <:> y

(<?&>) ::
  Eitherable repr =>
  Dimapable repr =>
  Permutable repr =>
  Tupable (Permutation repr) =>
  repr (a->k) k ->
  Permutation repr (b->k) k ->
  Permutation repr ((Maybe a,b)->k) k
x <?&> y = optionalPerm x <:> y

(<*&>) ::
  Eitherable repr =>
  Repeatable repr =>
  Dimapable repr =>
  Permutable repr =>
  Tupable (Permutation repr) =>
  repr (a->k) k ->
  Permutation repr (b->k) k ->
  Permutation repr (([a],b)->k) k
x <*&> y = permWithDefault [] (many1 x) <:> y

(<+&>) ::
  Eitherable repr =>
  Repeatable repr =>
  Dimapable repr =>
  Permutable repr =>
  Tupable (Permutation repr) =>
  repr (a->k) k ->
  Permutation repr (b->k) k ->
  Permutation repr (([a],b)->k) k
x <+&> y = perm (many1 x) <:> y

infixr 4 <&>
infixr 4 <?&>
infixr 4 <*&>
infixr 4 <+&>

{-# INLINE (<&>)  #-}
{-# INLINE (<?&>) #-}
{-# INLINE (<*&>) #-}
{-# INLINE (<+&>) #-}

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

-- * Class 'Routable'
class Routable repr where
  (<!>) :: repr a k -> repr b k -> repr (a:!:b) k
  (<!>) = liftDerived2 (<!>)
  default (<!>) ::
    FromDerived2 Routable repr =>
    repr a k -> repr b k -> repr (a:!:b) k
infixr 3 <!>

-- ** Type (':!:')
-- | Like @(,)@ but @infixr@.
-- Mostly useful for clarity when using 'Routable'.
data (:!:) a b = a:!:b
 deriving (Eq, Show)
infixr 3 :!:

-- * Class 'Substractable'
class Substractable repr where
  (<->) :: repr a k -> repr k' k' -> repr a k
  (<->) = liftDerived2 (<->)
  default (<->) ::
    FromDerived2 Substractable repr =>
    repr a k -> repr k' k' -> repr a k
infixr 3 <->

-- * Class 'Tupable'
class Tupable repr where
  (<:>) :: repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k
  (<:>) = liftDerived2 (<:>)
  default (<:>) ::
    FromDerived2 Tupable 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 = liftDerived unit
  default unit ::
    FromDerived Unitable repr =>
    repr (() -> k) k

-- * Class 'Voidable'
class Voidable repr where
  default void ::
    FromDerived1 Voidable repr =>
    a -> repr (a -> b) k -> repr b k
  void :: a -> repr (a -> b) k -> repr b k
  void a = liftDerived1 (void a)