symantic-base-0.2.0.20210731: src/Symantic/Lang.hs

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

import Data.Bool (Bool(..))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq)
import Data.Kind (Type)
import Data.Maybe (Maybe(..), fromJust)
import Data.Proxy (Proxy(..))
import GHC.Generics (Generic)
import qualified Data.Function as Fun

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

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

-- * Class 'Abstractable'
class Abstractable repr where
  -- | Application, aka. unabstract.
  (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
  -- | 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)
  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 $
  var :: repr a -> repr a
  (.@) = liftDerived2 (.@)
  lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))
  lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))
  const = liftDerived const
  flip = liftDerived flip
  id = liftDerived id
  (.) = liftDerived (.)
  ($) = liftDerived ($)
  var = liftDerived1 var
  default (.@) ::
    FromDerived2 Abstractable repr =>
    repr (a->b) -> repr a -> repr b
  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 const ::
    FromDerived Abstractable repr =>
    repr (a -> b -> a)
  default flip ::
    FromDerived Abstractable repr =>
    repr ((a -> b -> c) -> b -> a -> c)
  default id ::
    FromDerived Abstractable repr =>
    repr (a->a)
  default (.) ::
    FromDerived Abstractable repr =>
    repr ((b->c) -> (a->b) -> a -> c)
  default ($) ::
    FromDerived Abstractable repr =>
    repr ((a->b) -> a -> b)
  default var ::
    FromDerived1 Abstractable repr =>
    repr a -> repr a

-- * 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

bool :: Constantable Bool repr => Bool -> repr Bool
bool = constant @Bool
char :: Constantable Char repr => Char -> repr Char
char = constant @Char
unit :: Constantable () repr => repr ()
unit = constant @() ()

-- * 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 -> a -> Bool)
(==) = lam (\x -> lam (\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 '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
  (<%>) 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 }

-- * Class 'ProductFunctor'
class ProductFunctor repr where
  (<.>) :: repr a -> repr b -> repr (a, b)
  (<.>) = liftDerived2 (<.>)
  default (<.>) ::
    FromDerived2 ProductFunctor repr =>
    repr a -> repr b -> repr (a, b)

-- * Class 'AlternativeFunctor'
class AlternativeFunctor repr where
  (<+>) :: repr a -> repr a -> repr a
  (<+>) = liftDerived2 (<+>)
  default (<+>) ::
    FromDerived2 AlternativeFunctor repr =>
    repr a -> repr a -> repr a

-- * Class 'Dicurryable'
class Dicurryable repr where
  dicurry ::
    CurryN args =>
    proxy args ->
    (args-..->r) -> -- construction
    (r->Tuples args) -> -- destruction
    repr (args-..->k) ->
    repr (r->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) ->
    repr (r->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) ->
  repr (a -> k)
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 'Emptyable'
class Emptyable repr where
  empty :: repr a
  empty = liftDerived empty
  default empty ::
    FromDerived Emptyable repr =>
    repr a

-- ** 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

(<?&>) ::
  Eitherable repr =>
  IsoFunctor repr =>
  Permutable repr =>
  ProductFunctor (Permutation repr) =>
  repr a ->
  Permutation repr b ->
  Permutation repr (Maybe a, b)
x <?&> y = optionalPerm x <.> y

(<*&>) ::
  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

(<+&>) ::
  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 <&>
infixr 4 <?&>
infixr 4 <*&>
infixr 4 <+&>

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

-- * Class 'Routable'
class Routable repr where
  (<!>) :: repr a -> repr b -> repr (a, b)
  (<!>) = 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 3 :!:

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

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