{-# 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
  (<.>) = (Derived repr a b -> Derived repr b c -> Derived repr a c)
-> repr a b -> repr b c -> repr a c
forall (repr :: * -> * -> *) a ka b kb c kc.
LiftDerived2 repr =>
(Derived repr a ka -> Derived repr b kb -> Derived repr c kc)
-> repr a ka -> repr b kb -> repr c kc
liftDerived2 Derived repr a b -> Derived repr b c -> Derived repr a c
forall (repr :: * -> * -> *) a b c.
Composable repr =>
repr a b -> repr b c -> repr a c
(<.>)
  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 = Derived repr (a -> k) k -> repr (a -> k) k
forall (repr :: * -> * -> *) a ka.
LiftDerived repr =>
Derived repr a ka -> repr a ka
liftDerived (Derived repr (a -> k) k -> repr (a -> k) k)
-> (a -> Derived repr (a -> k) k) -> a -> repr (a -> k) k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Derived repr (a -> k) k
forall (repr :: * -> * -> *) a k.
Constant repr =>
a -> repr (a -> k) k
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 proxy args
args args -..-> r
constr r -> Tuples args
destr = (Derived repr (args -..-> k) k -> Derived repr (r -> k) k)
-> repr (args -..-> k) k -> repr (r -> k) k
forall (repr :: * -> * -> *) a ka b kb.
LiftDerived1 repr =>
(Derived repr a ka -> Derived repr b kb) -> repr a ka -> repr b kb
liftDerived1 (proxy args
-> (args -..-> r)
-> (r -> Tuples args)
-> Derived repr (args -..-> k) k
-> Derived repr (r -> k) k
forall (repr :: * -> * -> *) (args :: [*]) (proxy :: [*] -> *) r k.
(Dicurryable repr, CurryN args) =>
proxy args
-> (args -..-> r)
-> (r -> Tuples args)
-> repr (args -..-> k) k
-> repr (r -> k) k
dicurry proxy args
args args -..-> r
constr r -> Tuples args
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 :: (args -..-> a) -> repr (args -..-> k) k -> repr (a -> k) k
construct args -..-> a
f = Proxy args
-> (args -..-> a)
-> (a -> Tuples args)
-> repr (args -..-> k) k
-> repr (a -> k) k
forall (repr :: * -> * -> *) (args :: [*]) (proxy :: [*] -> *) r k.
(Dicurryable repr, CurryN args) =>
proxy args
-> (args -..-> r)
-> (r -> Tuples args)
-> repr (args -..-> k) k
-> repr (r -> k) k
dicurry (Proxy args
forall k (t :: k). Proxy t
Proxy::Proxy args) args -..-> a
f a -> Tuples args
forall a. (Generic a, EoTOfRep a) => a -> EoT (ADT a)
eotOfadt

-- * Class 'Dimapable'
class Dimapable repr where
  dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
  dimap a -> b
a2b b -> a
b2a = (Derived repr (a -> k) k -> Derived repr (b -> k) k)
-> repr (a -> k) k -> repr (b -> k) k
forall (repr :: * -> * -> *) a ka b kb.
LiftDerived1 repr =>
(Derived repr a ka -> Derived repr b kb) -> repr a ka -> repr b kb
liftDerived1 ((a -> b)
-> (b -> a) -> Derived repr (a -> k) k -> Derived repr (b -> k) k
forall (repr :: * -> * -> *) a b k.
Dimapable repr =>
(a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
dimap a -> b
a2b b -> a
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
  (<+>) = (Derived repr (a -> k) k
 -> Derived repr (b -> k) k -> Derived repr (Either a b -> k) k)
-> repr (a -> k) k -> repr (b -> k) k -> repr (Either a b -> k) k
forall (repr :: * -> * -> *) a ka b kb c kc.
LiftDerived2 repr =>
(Derived repr a ka -> Derived repr b kb -> Derived repr c kc)
-> repr a ka -> repr b kb -> repr c kc
liftDerived2 Derived repr (a -> k) k
-> Derived repr (b -> k) k -> Derived repr (Either a b -> k) k
forall (repr :: * -> * -> *) a k b.
Eitherable repr =>
repr (a -> k) k -> repr (b -> k) k -> repr (Either a b -> k) k
(<+>)
  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 :: repr (EoT (ADT adt) -> k) k -> repr (adt -> k) k
adt = (EoT (ADT adt) -> adt)
-> (adt -> EoT (ADT adt))
-> repr (EoT (ADT adt) -> k) k
-> repr (adt -> k) k
forall (repr :: * -> * -> *) a b k.
Dimapable repr =>
(a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
dimap EoT (ADT adt) -> adt
forall a. (Generic a, RepOfEoT a) => EoT (ADT a) -> a
adtOfeot adt -> EoT (ADT adt)
forall a. (Generic a, EoTOfRep a) => a -> EoT (ADT a)
eotOfadt

-- ** Class 'Emptyable'
class Emptyable repr where
  empty :: repr k k
  empty = Derived repr k k -> repr k k
forall (repr :: * -> * -> *) a ka.
LiftDerived repr =>
Derived repr a ka -> repr a ka
liftDerived Derived repr k k
forall (repr :: * -> * -> *) k. Emptyable repr => repr k k
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 = (Derived repr k k -> Derived repr k k) -> repr k k -> repr k k
forall (repr :: * -> * -> *) a ka b kb.
LiftDerived1 repr =>
(Derived repr a ka -> Derived repr b kb) -> repr a ka -> repr b kb
liftDerived1 Derived repr k k -> Derived repr k k
forall (repr :: * -> * -> *) k.
Optionable repr =>
repr k k -> repr k k
option
  optional = (Derived repr (a -> k) k -> Derived repr (Maybe a -> k) k)
-> repr (a -> k) k -> repr (Maybe a -> k) k
forall (repr :: * -> * -> *) a ka b kb.
LiftDerived1 repr =>
(Derived repr a ka -> Derived repr b kb) -> repr a ka -> repr b kb
liftDerived1 Derived repr (a -> k) k -> Derived repr (Maybe a -> k) k
forall (repr :: * -> * -> *) a k.
Optionable repr =>
repr (a -> k) k -> repr (Maybe a -> k) k
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 = Maybe a
-> repr (Maybe a -> k) k -> Permutation repr (Maybe a -> k) k
forall (repr :: * -> * -> *) a k.
Permutable repr =>
a -> repr (a -> k) k -> Permutation repr (a -> k) k
permWithDefault Maybe a
forall a. Maybe a
Nothing (repr (Maybe a -> k) k -> Permutation repr (Maybe a -> k) k)
-> (repr (a -> k) k -> repr (Maybe a -> k) k)
-> repr (a -> k) k
-> Permutation repr (Maybe a -> k) k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a)
-> (Maybe a -> a) -> repr (a -> k) k -> repr (Maybe a -> k) k
forall (repr :: * -> * -> *) a b k.
Dimapable repr =>
(a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
dimap a -> Maybe a
forall a. a -> Maybe a
Just Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust

(<&>) ::
  Permutable repr =>
  Tupable (Permutation repr) =>
  repr (a->k) k ->
  Permutation repr (b->k) k ->
  Permutation repr ((a,b)->k) k
repr (a -> k) k
x <&> :: repr (a -> k) k
-> Permutation repr (b -> k) k -> Permutation repr ((a, b) -> k) k
<&> Permutation repr (b -> k) k
y = repr (a -> k) k -> Permutation repr (a -> k) k
forall (repr :: * -> * -> *) a k.
Permutable repr =>
repr (a -> k) k -> Permutation repr (a -> k) k
perm repr (a -> k) k
x Permutation repr (a -> k) k
-> Permutation repr (b -> k) k -> Permutation repr ((a, b) -> k) k
forall (repr :: * -> * -> *) a k b.
Tupable repr =>
repr (a -> k) k -> repr (b -> k) k -> repr ((a, b) -> k) k
<:> Permutation repr (b -> k) k
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
repr (a -> k) k
x <?&> :: repr (a -> k) k
-> Permutation repr (b -> k) k
-> Permutation repr ((Maybe a, b) -> k) k
<?&> Permutation repr (b -> k) k
y = repr (a -> k) k -> Permutation repr (Maybe a -> k) k
forall (repr :: * -> * -> *) a k.
(Permutable repr, Eitherable repr, Dimapable repr,
 Permutable repr) =>
repr (a -> k) k -> Permutation repr (Maybe a -> k) k
optionalPerm repr (a -> k) k
x Permutation repr (Maybe a -> k) k
-> Permutation repr (b -> k) k
-> Permutation repr ((Maybe a, b) -> k) k
forall (repr :: * -> * -> *) a k b.
Tupable repr =>
repr (a -> k) k -> repr (b -> k) k -> repr ((a, b) -> k) k
<:> Permutation repr (b -> k) k
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
repr (a -> k) k
x <*&> :: repr (a -> k) k
-> Permutation repr (b -> k) k
-> Permutation repr (([a], b) -> k) k
<*&> Permutation repr (b -> k) k
y = [a] -> repr ([a] -> k) k -> Permutation repr ([a] -> k) k
forall (repr :: * -> * -> *) a k.
Permutable repr =>
a -> repr (a -> k) k -> Permutation repr (a -> k) k
permWithDefault [] (repr (a -> k) k -> repr ([a] -> k) k
forall (repr :: * -> * -> *) a k.
Repeatable repr =>
repr (a -> k) k -> repr ([a] -> k) k
many1 repr (a -> k) k
x) Permutation repr ([a] -> k) k
-> Permutation repr (b -> k) k
-> Permutation repr (([a], b) -> k) k
forall (repr :: * -> * -> *) a k b.
Tupable repr =>
repr (a -> k) k -> repr (b -> k) k -> repr ((a, b) -> k) k
<:> Permutation repr (b -> k) k
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
repr (a -> k) k
x <+&> :: repr (a -> k) k
-> Permutation repr (b -> k) k
-> Permutation repr (([a], b) -> k) k
<+&> Permutation repr (b -> k) k
y = repr ([a] -> k) k -> Permutation repr ([a] -> k) k
forall (repr :: * -> * -> *) a k.
Permutable repr =>
repr (a -> k) k -> Permutation repr (a -> k) k
perm (repr (a -> k) k -> repr ([a] -> k) k
forall (repr :: * -> * -> *) a k.
Repeatable repr =>
repr (a -> k) k -> repr ([a] -> k) k
many1 repr (a -> k) k
x) Permutation repr ([a] -> k) k
-> Permutation repr (b -> k) k
-> Permutation repr (([a], b) -> k) k
forall (repr :: * -> * -> *) a k b.
Tupable repr =>
repr (a -> k) k -> repr (b -> k) k -> repr ((a, b) -> k) k
<:> Permutation repr (b -> k) k
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 = (Derived repr (a -> k) k -> Derived repr ([a] -> k) k)
-> repr (a -> k) k -> repr ([a] -> k) k
forall (repr :: * -> * -> *) a ka b kb.
LiftDerived1 repr =>
(Derived repr a ka -> Derived repr b kb) -> repr a ka -> repr b kb
liftDerived1 Derived repr (a -> k) k -> Derived repr ([a] -> k) k
forall (repr :: * -> * -> *) a k.
Repeatable repr =>
repr (a -> k) k -> repr ([a] -> k) k
many0
  many1 = (Derived repr (a -> k) k -> Derived repr ([a] -> k) k)
-> repr (a -> k) k -> repr ([a] -> k) k
forall (repr :: * -> * -> *) a ka b kb.
LiftDerived1 repr =>
(Derived repr a ka -> Derived repr b kb) -> repr a ka -> repr b kb
liftDerived1 Derived repr (a -> k) k -> Derived repr ([a] -> k) k
forall (repr :: * -> * -> *) a k.
Repeatable repr =>
repr (a -> k) k -> repr ([a] -> k) k
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
  (<!>) = (Derived repr a k -> Derived repr b k -> Derived repr (a :!: b) k)
-> repr a k -> repr b k -> repr (a :!: b) k
forall (repr :: * -> * -> *) a ka b kb c kc.
LiftDerived2 repr =>
(Derived repr a ka -> Derived repr b kb -> Derived repr c kc)
-> repr a ka -> repr b kb -> repr c kc
liftDerived2 Derived repr a k -> Derived repr b k -> Derived repr (a :!: b) k
forall (repr :: * -> * -> *) a k b.
Routable repr =>
repr a k -> repr b k -> repr (a :!: b) k
(<!>)
  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 ((a :!: b) -> (a :!: b) -> Bool
((a :!: b) -> (a :!: b) -> Bool)
-> ((a :!: b) -> (a :!: b) -> Bool) -> Eq (a :!: b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => (a :!: b) -> (a :!: b) -> Bool
/= :: (a :!: b) -> (a :!: b) -> Bool
$c/= :: forall a b. (Eq a, Eq b) => (a :!: b) -> (a :!: b) -> Bool
== :: (a :!: b) -> (a :!: b) -> Bool
$c== :: forall a b. (Eq a, Eq b) => (a :!: b) -> (a :!: b) -> Bool
Eq, Int -> (a :!: b) -> ShowS
[a :!: b] -> ShowS
(a :!: b) -> String
(Int -> (a :!: b) -> ShowS)
-> ((a :!: b) -> String) -> ([a :!: b] -> ShowS) -> Show (a :!: b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> (a :!: b) -> ShowS
forall a b. (Show a, Show b) => [a :!: b] -> ShowS
forall a b. (Show a, Show b) => (a :!: b) -> String
showList :: [a :!: b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [a :!: b] -> ShowS
show :: (a :!: b) -> String
$cshow :: forall a b. (Show a, Show b) => (a :!: b) -> String
showsPrec :: Int -> (a :!: b) -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> (a :!: b) -> ShowS
Show)
infixr 3 :!:

-- * Class 'Substractable'
class Substractable repr where
  (<->) :: repr a k -> repr k' k' -> repr a k
  (<->) = (Derived repr a k -> Derived repr k' k' -> Derived repr a k)
-> repr a k -> repr k' k' -> repr a k
forall (repr :: * -> * -> *) a ka b kb c kc.
LiftDerived2 repr =>
(Derived repr a ka -> Derived repr b kb -> Derived repr c kc)
-> repr a ka -> repr b kb -> repr c kc
liftDerived2 Derived repr a k -> Derived repr k' k' -> Derived repr a k
forall (repr :: * -> * -> *) a k k'.
Substractable repr =>
repr a k -> repr k' k' -> repr a k
(<->)
  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
  (<:>) = (Derived repr (a -> k) k
 -> Derived repr (b -> k) k -> Derived repr ((a, b) -> k) k)
-> repr (a -> k) k -> repr (b -> k) k -> repr ((a, b) -> k) k
forall (repr :: * -> * -> *) a ka b kb c kc.
LiftDerived2 repr =>
(Derived repr a ka -> Derived repr b kb -> Derived repr c kc)
-> repr a ka -> repr b kb -> repr c kc
liftDerived2 Derived repr (a -> k) k
-> Derived repr (b -> k) k -> Derived repr ((a, b) -> k) k
forall (repr :: * -> * -> *) a k b.
Tupable repr =>
repr (a -> k) k -> repr (b -> k) k -> repr ((a, b) -> k) k
(<:>)
  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 = Derived repr (() -> k) k -> repr (() -> k) k
forall (repr :: * -> * -> *) a ka.
LiftDerived repr =>
Derived repr a ka -> repr a ka
liftDerived Derived repr (() -> k) k
forall (repr :: * -> * -> *) k. Unitable repr => repr (() -> k) k
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
a = (Derived repr (a -> b) k -> Derived repr b k)
-> repr (a -> b) k -> repr b k
forall (repr :: * -> * -> *) a ka b kb.
LiftDerived1 repr =>
(Derived repr a ka -> Derived repr b kb) -> repr a ka -> repr b kb
liftDerived1 (a -> Derived repr (a -> b) k -> Derived repr b k
forall (repr :: * -> * -> *) a b k.
Voidable repr =>
a -> repr (a -> b) k -> repr b k
void a
a)