symantic-base-0.3.0.20211007: src/Symantic/Class.hs

{-# LANGUAGE DataKinds #-} -- For ReprKind
{-# LANGUAGE PatternSynonyms #-} -- For (:!:)
{-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation
{-# LANGUAGE UndecidableInstances #-} -- For Permutation
module Symantic.Class where

import Data.Bool (Bool(..))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq)
import Data.Int (Int)
import Data.Kind (Type)
import Data.Maybe (Maybe(..), fromJust)
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup)
import Data.String (String)
import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import qualified Control.Category as Cat
import qualified Data.Function as Fun
import qualified Data.Tuple as Tuple

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

-- * Type 'ReprKind'
type ReprKind = Type -> Type

-- * Class 'Abstractable'
class Abstractable repr where
  -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
  lam :: (repr a -> repr b) -> repr (a->b)
  -- | Like 'lam' but whose argument is used only once,
  -- hence safe to beta-reduce (inline) without duplicating work.
  lam1 :: (repr a -> repr b) -> repr (a->b)
  var :: repr a -> repr a
  -- | Application, aka. unabstract.
  (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
  lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))
  lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))
  var = liftDerived1 var
  (.@) = liftDerived2 (.@)
  default lam ::
    FromDerived Abstractable repr => Derivable repr =>
    (repr a -> repr b) -> repr (a->b)
  default lam1 ::
    FromDerived Abstractable repr => Derivable repr =>
    (repr a -> repr b) -> repr (a->b)
  default var ::
    FromDerived1 Abstractable repr =>
    repr a -> repr a
  default (.@) ::
    FromDerived2 Abstractable repr =>
    repr (a->b) -> repr a -> repr b

-- ** Class 'Functionable'
class Functionable repr where
  const :: repr (a -> b -> a)
  flip :: repr ((a -> b -> c) -> b -> a -> c)
  id :: repr (a->a)
  (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
  ($) :: repr ((a->b) -> a -> b); infixr 0 $
  const = liftDerived const
  flip = liftDerived flip
  id = liftDerived id
  (.) = liftDerived (.)
  ($) = liftDerived ($)
  default const ::
    FromDerived Functionable repr =>
    repr (a -> b -> a)
  default flip ::
    FromDerived Functionable repr =>
    repr ((a -> b -> c) -> b -> a -> c)
  default id ::
    FromDerived Functionable repr =>
    repr (a->a)
  default (.) ::
    FromDerived Functionable repr =>
    repr ((b->c) -> (a->b) -> a -> c)
  default ($) ::
    FromDerived Functionable repr =>
    repr ((a->b) -> a -> b)

-- * Class 'Anythingable'
class Anythingable repr where
  anything :: repr a -> repr a
  anything = Fun.id

-- * Class 'Bottomable'
class Bottomable repr where
  bottom :: repr a

-- * Class 'Constantable'
class Constantable c repr where
  constant :: c -> repr c
  constant = liftDerived Fun.. constant
  default constant ::
    FromDerived (Constantable c) repr =>
    c -> repr c

-- * Class 'Eitherable'
class Eitherable repr where
  left :: repr (l -> Either l r)
  right :: repr (r -> Either l r)
  left = liftDerived left
  right = liftDerived right
  default left ::
    FromDerived Eitherable repr =>
    repr (l -> Either l r)
  default right ::
    FromDerived Eitherable repr =>
    repr (r -> Either l r)

-- * Class 'Equalable'
class Equalable repr where
  equal :: Eq a => repr (a -> a -> Bool)
  equal = liftDerived equal
  default equal ::
    FromDerived Equalable repr =>
    Eq a => repr (a -> a -> Bool)

infix 4 `equal`, ==
(==) ::
  Abstractable repr => Equalable repr => Eq a =>
  repr a -> repr a -> repr Bool
(==) x y = equal .@ x .@ y

-- * Class 'IfThenElseable'
class IfThenElseable repr where
  ifThenElse :: repr Bool -> repr a -> repr a -> repr a
  ifThenElse = liftDerived3 ifThenElse
  default ifThenElse ::
    FromDerived3 IfThenElseable repr =>
    repr Bool -> repr a -> repr a -> repr a

-- * Class 'Inferable'
class Inferable a repr where
  infer :: repr a
  default infer :: FromDerived (Inferable a) repr => repr a
  infer = liftDerived infer

unit :: Inferable () repr => repr ()
unit = infer
bool :: Inferable Bool repr => repr Bool
bool = infer
char :: Inferable Char repr => repr Char
char = infer
int :: Inferable Int repr => repr Int
int = infer
natural :: Inferable Natural repr => repr Natural
natural = infer
string :: Inferable String repr => repr String
string = infer

-- * Class 'Listable'
class Listable repr where
  cons :: repr (a -> [a] -> [a])
  nil :: repr [a]
  cons = liftDerived cons
  nil = liftDerived nil
  default cons ::
    FromDerived Listable repr =>
    repr (a -> [a] -> [a])
  default nil ::
    FromDerived Listable repr =>
    repr [a]

-- * Class 'Maybeable'
class Maybeable repr where
  nothing :: repr (Maybe a)
  just :: repr (a -> Maybe a)
  nothing = liftDerived nothing
  just = liftDerived just
  default nothing ::
    FromDerived Maybeable repr =>
    repr (Maybe a)
  default just ::
    FromDerived Maybeable repr =>
    repr (a -> Maybe a)

-- * Class 'IsoFunctor'
class IsoFunctor repr where
  (<%>) :: Iso a b -> repr a -> repr b; infixl 4 <%>
  (<%>) iso = liftDerived1 (iso <%>)
  default (<%>) ::
    FromDerived1 IsoFunctor repr =>
    Iso a b -> repr a -> repr b

-- ** Type 'Iso'
data Iso a b = Iso { a2b :: a->b, b2a :: b->a }
instance Cat.Category Iso where
  id = Iso Cat.id Cat.id
  f . g = Iso (a2b f Cat.. a2b g) (b2a g Cat.. b2a f)

-- * Class 'ProductFunctor'
-- | Beware that this is an @infixr@,
-- not @infixl@ like to 'Control.Applicative.<*>';
-- this is to follow what is expected by 'ADT'.
class ProductFunctor repr where
  (<.>) :: repr a -> repr b -> repr (a, b); infixr 4 <.>
  (<.>) = liftDerived2 (<.>)
  default (<.>) ::
    FromDerived2 ProductFunctor repr =>
    repr a -> repr b -> repr (a, b)
  (<.) :: repr a -> repr () -> repr a; infixr 4 <.
  ra <. rb = Iso Tuple.fst (, ()) <%> (ra <.> rb)
  default (<.) :: IsoFunctor repr => repr a -> repr () -> repr a
  (.>) :: repr () -> repr a -> repr a; infixr 4 .>
  ra .> rb = Iso Tuple.snd (() ,) <%> (ra <.> rb)
  default (.>) :: IsoFunctor repr => repr () -> repr a -> repr a

-- * Class 'SumFunctor'
-- | Beware that this is an @infixr@,
-- not @infixl@ like to 'Control.Applicative.<|>';
-- this is to follow what is expected by 'ADT'.
class SumFunctor repr where
  (<+>) :: repr a -> repr b -> repr (Either a b); infixr 3 <+>
  (<+>) = liftDerived2 (<+>)
  default (<+>) ::
    FromDerived2 SumFunctor repr =>
    repr a -> repr b -> repr (Either a b)

-- * Class 'AlternativeFunctor'
-- | Beware that this is an @infixr@,
-- not @infixl@ like to 'Control.Applicative.<|>';
-- this is to follow what is expected by 'ADT'.
class AlternativeFunctor repr where
  (<|>) :: repr a -> repr a -> repr a; infixr 3 <|>
  (<|>) = liftDerived2 (<|>)
  default (<|>) ::
    FromDerived2 AlternativeFunctor repr =>
    repr a -> repr a -> repr a

-- * Class 'Dicurryable'
class Dicurryable repr where
  dicurry ::
    CurryN args =>
    proxy args ->
    (args-..->a) -> -- construction
    (a->Tuples args) -> -- destruction
    repr (Tuples args) ->
    repr a
  dicurry args constr destr = liftDerived1 (dicurry args constr destr)
  default dicurry ::
    FromDerived1 Dicurryable repr =>
    CurryN args =>
    proxy args ->
    (args-..->a) ->
    (a->Tuples args) ->
    repr (Tuples args) ->
    repr a

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

adt ::
  forall adt repr.
  IsoFunctor repr =>
  Generic adt =>
  RepOfEoT adt =>
  EoTOfRep adt =>
  repr (EoT (ADT adt)) ->
  repr adt
adt = (<%>) (Iso adtOfeot eotOfadt)

-- * Class 'Monoidable'
class
  ( Emptyable repr
  , Semigroupable repr
  ) => Monoidable repr
instance
  ( Emptyable repr
  , Semigroupable repr
  ) => Monoidable repr

-- ** Class 'Emptyable'
class Emptyable repr where
  empty :: repr a
  empty = liftDerived empty
  default empty ::
    FromDerived Emptyable repr =>
    repr a

-- ** Class 'Semigroupable'
class Semigroupable repr where
  concat :: Semigroup a => repr (a -> a -> a)
  concat = liftDerived concat
  default concat ::
    FromDerived Semigroupable repr =>
    Semigroup a =>
    repr (a -> a -> a)

infixr 6 `concat`, <>
(<>) ::
  Abstractable repr => Semigroupable repr => Semigroup a =>
  repr a -> repr a -> repr a
(<>) x y = concat .@ x .@ y

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

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

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

(<&>) ::
  Permutable repr =>
  ProductFunctor (Permutation repr) =>
  repr a ->
  Permutation repr b ->
  Permutation repr (a, b)
x <&> y = perm x <.> y
infixr 4 <&>
{-# INLINE (<&>)  #-}

(<?&>) ::
  Eitherable repr =>
  IsoFunctor repr =>
  Permutable repr =>
  ProductFunctor (Permutation repr) =>
  repr a ->
  Permutation repr b ->
  Permutation repr (Maybe a, b)
x <?&> y = optionalPerm x <.> y
infixr 4 <?&>
{-# INLINE (<?&>) #-}

(<*&>) ::
  Eitherable repr =>
  Repeatable repr =>
  IsoFunctor repr =>
  Permutable repr =>
  ProductFunctor (Permutation repr) =>
  repr a ->
  Permutation repr b ->
  Permutation repr ([a],b)
x <*&> y = permWithDefault [] (many1 x) <.> y
infixr 4 <*&>
{-# INLINE (<*&>) #-}

(<+&>) ::
  Eitherable repr =>
  Repeatable repr =>
  IsoFunctor repr =>
  Permutable repr =>
  ProductFunctor (Permutation repr) =>
  repr a ->
  Permutation repr b ->
  Permutation repr ([a], b)
x <+&> y = perm (many1 x) <.> y
infixr 4 <+&>
{-# INLINE (<+&>) #-}

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

-- | Like @(,)@ but @infixr@.
-- Mostly useful for clarity when using 'Routable'.
pattern (:!:) :: a -> b -> (a, b)
pattern a:!:b <- (a, b)
  where a:!:b = (a, b)
infixr 4 :!:

-- * Class 'Voidable'
-- | FIXME: this class should likely be removed
class Voidable repr where
  void :: a -> repr a -> repr ()
  void = liftDerived1 Fun.. void
  default void ::
    FromDerived1 Voidable repr =>
    a -> repr a -> repr ()

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