-{-# LANGUAGE DataKinds #-} -- For ReprKind
-{-# LANGUAGE PatternSynonyms #-} -- For (:!:)
-{-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation
-{-# LANGUAGE UndecidableInstances #-} -- For Permutation
+-- For ifSemantic
+{-# LANGUAGE AllowAmbiguousTypes #-}
+-- For Syntax
+{-# LANGUAGE DataKinds #-}
+-- For (:!:)
+{-# LANGUAGE PatternSynonyms #-}
+-- For ifSemantic
+{-# LANGUAGE RankNTypes #-}
+-- For Permutation
+{-# LANGUAGE TypeFamilyDependencies #-}
+-- For Permutation
+{-# LANGUAGE UndecidableInstances #-}
+
-- | Combinators in this module conflict with usual ones from the @Prelude@
-- hence they are meant to be imported either explicitely or qualified.
-module Symantic.Classes where
+module Symantic.Syntaxes.Classes where
-import Data.Bool (Bool(..))
+import Control.Category qualified as Cat
+import Data.Bool (Bool (..))
import Data.Char (Char)
-import Data.Either (Either(..))
+import Data.Either (Either (..))
import Data.Eq (Eq)
+import Data.Function qualified as Fun
import Data.Int (Int)
-import Data.Kind (Type)
-import Data.Maybe (Maybe(..), fromJust)
-import Data.Proxy (Proxy(..))
+import Data.Kind (Constraint)
+import Data.Maybe (Maybe (..), fromJust)
+import Data.Proxy (Proxy (..))
import Data.Semigroup (Semigroup)
import Data.String (String)
+import Data.Tuple qualified as Tuple
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
+import Symantic.Syntaxes.CurryN
+import Symantic.Syntaxes.Derive
+import Symantic.Syntaxes.EithersOfTuples
-- * Type 'Syntax'
type Syntax = Semantic -> Constraint
-- ** Type family 'Syntaxes'
+
-- | Merge several 'Syntax'es into a single one.
--
-- Useful in 'IfSemantic'.
Syntaxes '[] sem = ()
Syntaxes (syn ': syns) sem = (syn sem, Syntaxes syns sem)
--- * Type 'Semantic'
--- | The kind of @sem@(antics) throughout this library.
-type Semantic = Type -> Type
-
-- * Class 'Abstractable'
-class Abstractable sem where
+class Unabstractable sem => Abstractable sem where
-- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
- lam :: (sem a -> sem b) -> sem (a->b)
+ lam :: (sem a -> sem b) -> sem (a -> b)
+
-- | Like 'lam' but whose argument must be used only once,
-- hence safe to beta-reduce (inline) without duplicating work.
- lam1 :: (sem a -> sem b) -> sem (a->b)
+ lam1 :: (sem a -> sem b) -> sem (a -> b)
+
var :: sem a -> sem a
- -- | Application, aka. unabstract.
- (.@) :: sem (a->b) -> sem a -> sem 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 sem => Derivable sem =>
- (sem a -> sem b) -> sem (a->b)
+ FromDerived Abstractable sem =>
+ Derivable sem =>
+ (sem a -> sem b) ->
+ sem (a -> b)
default lam1 ::
- FromDerived Abstractable sem => Derivable sem =>
- (sem a -> sem b) -> sem (a->b)
+ FromDerived Abstractable sem =>
+ Derivable sem =>
+ (sem a -> sem b) ->
+ sem (a -> b)
default var ::
FromDerived1 Abstractable sem =>
- sem a -> sem a
+ sem a ->
+ sem a
+
+-- ** Class 'Unabstractable'
+class Unabstractable sem where
+ -- | Application, aka. unabstract.
+ (.@) :: sem (a -> b) -> sem a -> sem b
+
+ infixl 9 .@
+ (.@) = liftDerived2 (.@)
default (.@) ::
- FromDerived2 Abstractable sem =>
- sem (a->b) -> sem a -> sem b
+ FromDerived2 Unabstractable sem =>
+ sem (a -> b) ->
+ sem a ->
+ sem b
-- ** Class 'Functionable'
class Functionable sem where
const :: sem (a -> b -> a)
flip :: sem ((a -> b -> c) -> b -> a -> c)
- id :: sem (a->a)
- (.) :: sem ((b->c) -> (a->b) -> a -> c); infixr 9 .
- ($) :: sem ((a->b) -> a -> b); infixr 0 $
+ id :: sem (a -> a)
+ (.) :: sem ((b -> c) -> (a -> b) -> a -> c)
+ infixr 9 .
+ ($) :: sem ((a -> b) -> a -> b)
+ infixr 0 $
const = liftDerived const
flip = liftDerived flip
id = liftDerived id
sem ((a -> b -> c) -> b -> a -> c)
default id ::
FromDerived Functionable sem =>
- sem (a->a)
+ sem (a -> a)
default (.) ::
FromDerived Functionable sem =>
- sem ((b->c) -> (a->b) -> a -> c)
+ sem ((b -> c) -> (a -> b) -> a -> c)
default ($) ::
FromDerived Functionable sem =>
- sem ((a->b) -> a -> b)
+ sem ((a -> b) -> a -> b)
-- * Class 'Anythingable'
class Anythingable sem where
constant = liftDerived Fun.. constant
default constant ::
FromDerived (Constantable c) sem =>
- c -> sem c
+ c ->
+ sem c
-- * Class 'Eitherable'
class Eitherable sem where
+ either :: sem ((l -> a) -> (r -> a) -> Either l r -> a)
left :: sem (l -> Either l r)
right :: sem (r -> Either l r)
+ either = liftDerived either
left = liftDerived left
right = liftDerived right
+ default either ::
+ FromDerived Eitherable sem =>
+ sem ((l -> a) -> (r -> a) -> Either l r -> a)
default left ::
FromDerived Eitherable sem =>
sem (l -> Either l r)
equal = liftDerived equal
default equal ::
FromDerived Equalable sem =>
- Eq a => sem (a -> a -> Bool)
+ Eq a =>
+ sem (a -> a -> Bool)
infix 4 `equal`, ==
(==) ::
- Abstractable sem => Equalable sem => Eq a =>
- sem a -> sem a -> sem Bool
+ Abstractable sem =>
+ Equalable sem =>
+ Eq a =>
+ sem a ->
+ sem a ->
+ sem Bool
(==) x y = equal .@ x .@ y
-- * Class 'IfThenElseable'
ifThenElse = liftDerived3 ifThenElse
default ifThenElse ::
FromDerived3 IfThenElseable sem =>
- sem Bool -> sem a -> sem a -> sem a
+ sem Bool ->
+ sem a ->
+ sem a ->
+ sem a
-- * Class 'Inferable'
class Inferable a sem where
-- * Class 'IsoFunctor'
class IsoFunctor sem where
- (<%>) :: Iso a b -> sem a -> sem b; infixl 4 <%>
+ (<%>) :: Iso a b -> sem a -> sem b
+ infixl 4 <%>
(<%>) iso = liftDerived1 (iso <%>)
default (<%>) ::
FromDerived1 IsoFunctor sem =>
- Iso a b -> sem a -> sem b
+ Iso a b ->
+ sem a ->
+ sem b
-- ** Type 'Iso'
-data Iso a b = Iso { a2b :: a->b, b2a :: b->a }
+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 'Control.Applicative.<*>';
-- this is to follow what is expected by 'ADT'.
class ProductFunctor sem where
- (<.>) :: sem a -> sem b -> sem (a, b); infixr 4 <.>
+ (<.>) :: sem a -> sem b -> sem (a, b)
+ infixr 4 <.>
(<.>) = liftDerived2 (<.>)
default (<.>) ::
FromDerived2 ProductFunctor sem =>
- sem a -> sem b -> sem (a, b)
- (<.) :: sem a -> sem () -> sem a; infixr 4 <.
- ra <. rb = Iso Tuple.fst (, ()) <%> (ra <.> rb)
+ sem a ->
+ sem b ->
+ sem (a, b)
+ (<.) :: sem a -> sem () -> sem a
+ infixr 4 <.
+ ra <. rb = Iso Tuple.fst (,()) <%> (ra <.> rb)
default (<.) :: IsoFunctor sem => sem a -> sem () -> sem a
- (.>) :: sem () -> sem a -> sem a; infixr 4 .>
- ra .> rb = Iso Tuple.snd (() ,) <%> (ra <.> rb)
+ (.>) :: sem () -> sem a -> sem a
+ infixr 4 .>
+ ra .> rb = Iso Tuple.snd ((),) <%> (ra <.> rb)
default (.>) :: IsoFunctor sem => sem () -> sem a -> sem a
-- * Class 'SumFunctor'
+
-- | Beware that this is an @infixr@,
-- not @infixl@ like 'Control.Applicative.<|>';
-- this is to follow what is expected by 'ADT'.
class SumFunctor sem where
- (<+>) :: sem a -> sem b -> sem (Either a b); infixr 3 <+>
+ (<+>) :: sem a -> sem b -> sem (Either a b)
+ infixr 3 <+>
(<+>) = liftDerived2 (<+>)
default (<+>) ::
FromDerived2 SumFunctor sem =>
- sem a -> sem b -> sem (Either a b)
+ sem a ->
+ sem b ->
+ sem (Either a b)
+
+-- | Like @(,)@ but @infixr@.
+-- Mostly useful for clarity when using 'SumFunctor'.
+pattern (:!:) :: a -> b -> (a, b)
+pattern a :!: b <-
+ (a, b)
+ where
+ a :!: b = (a, b)
+
+infixr 4 :!:
+{-# COMPLETE (:!:) #-}
-- * Class 'AlternativeFunctor'
+
-- | Beware that this is an @infixr@,
-- not @infixl@ like 'Control.Applicative.<|>';
-- this is to follow what is expected by 'ADT'.
class AlternativeFunctor sem where
- (<|>) :: sem a -> sem a -> sem a; infixr 3 <|>
+ (<|>) :: sem a -> sem a -> sem a
+ infixr 3 <|>
(<|>) = liftDerived2 (<|>)
default (<|>) ::
FromDerived2 AlternativeFunctor sem =>
- sem a -> sem a -> sem a
+ sem a ->
+ sem a ->
+ sem a
-- * Class 'Dicurryable'
class Dicurryable sem where
dicurry ::
CurryN args =>
proxy args ->
- (args-..->a) -> -- construction
- (a->Tuples args) -> -- destruction
+ (args -..-> a) -> -- construction
+ (a -> Tuples args) -> -- destruction
sem (Tuples args) ->
sem a
dicurry args constr destr = liftDerived1 (dicurry args constr destr)
FromDerived1 Dicurryable sem =>
CurryN args =>
proxy args ->
- (args-..->a) ->
- (a->Tuples args) ->
+ (args -..-> a) ->
+ (a -> Tuples args) ->
sem (Tuples args) ->
sem a
EoTOfRep a =>
CurryN args =>
Tuples args ~ EoT (ADT a) =>
- (args ~ Args (args-..->a)) =>
- (args-..->a) ->
+ (args ~ Args (args -..-> a)) =>
+ (args -..-> a) ->
sem (Tuples args) ->
sem a
-construct f = dicurry (Proxy::Proxy args) f eotOfadt
-
-adt ::
- forall adt sem.
- IsoFunctor sem =>
- Generic adt =>
- RepOfEoT adt =>
- EoTOfRep adt =>
- sem (EoT (ADT adt)) ->
- sem adt
-adt = (<%>) (Iso adtOfeot eotOfadt)
+construct f = dicurry (Proxy :: Proxy args) f eotOfadt
+
+-- * Class 'Dataable'
+
+-- | Enable the contruction or deconstruction
+-- of an 'ADT' (algebraic data type).
+class Dataable a sem where
+ dataType :: sem (EoT (ADT a)) -> sem a
+ default dataType ::
+ Generic a =>
+ RepOfEoT a =>
+ EoTOfRep a =>
+ IsoFunctor sem =>
+ sem (EoT (ADT a)) ->
+ sem a
+ dataType = (<%>) (Iso adtOfeot eotOfadt)
-- * Class 'IfSemantic'
+
-- | 'IfSemantic' enables to change the 'Syntax' for a specific 'Semantic'.
--
-- Useful when a 'Semantic' does not implement some 'Syntax'es used by other 'Semantic's.
(Syntaxes thenSyntaxes thenSemantic => thenSemantic a) ->
(Syntaxes elseSyntaxes elseSemantic => elseSemantic a) ->
elseSemantic a
+
instance
{-# OVERLAPPING #-}
Syntaxes thenSyntaxes thenSemantic =>
- IfSemantic thenSyntaxes elseSyntaxes thenSemantic thenSemantic where
+ IfSemantic thenSyntaxes elseSyntaxes thenSemantic thenSemantic
+ where
ifSemantic thenSyntax _elseSyntax = thenSyntax
instance
Syntaxes elseSyntaxes elseSemantic =>
- IfSemantic thenSyntaxes elseSyntaxes thenSemantic elseSemantic where
+ IfSemantic thenSyntaxes elseSyntaxes thenSemantic elseSemantic
+ where
ifSemantic _thenSyntax elseSyntax = elseSyntax
-- * Class 'Monoidable'
class
( Emptyable sem
, Semigroupable sem
- ) => Monoidable sem
+ ) =>
+ Monoidable sem
instance
( Emptyable sem
, Semigroupable sem
- ) => Monoidable sem
+ ) =>
+ Monoidable sem
-- ** Class 'Emptyable'
class Emptyable sem where
infixr 6 `concat`, <>
(<>) ::
- Abstractable sem => Semigroupable sem => Semigroup a =>
- sem a -> sem a -> sem a
+ Abstractable sem =>
+ Semigroupable sem =>
+ Semigroup a =>
+ sem a ->
+ sem a ->
+ sem a
(<>) x y = concat .@ x .@ y
-- ** Class 'Optionable'
optional = liftDerived1 optional
default optional ::
FromDerived1 Optionable sem =>
- sem a -> sem (Maybe a)
+ sem a ->
+ sem (Maybe a)
-- * Class 'Repeatable'
class Repeatable sem where
many1 = liftDerived1 many1
default many0 ::
FromDerived1 Repeatable sem =>
- sem a -> sem [a]
+ sem a ->
+ sem [a]
default many1 ::
FromDerived1 Repeatable sem =>
- sem a -> sem [a]
+ sem a ->
+ sem [a]
-- | Alias to 'many0'.
many :: Repeatable sem => sem a -> sem [a]
-- * Class 'Permutable'
class Permutable sem where
-- Use @TypeFamilyDependencies@ to help type-inference infer @(sem)@.
- type Permutation (sem:: Semantic) = (r :: Semantic) | r -> sem
+ type Permutation (sem :: Semantic) = (r :: Semantic) | r -> sem
type Permutation sem = Permutation (Derived sem)
permutable :: Permutation sem a -> sem a
perm :: sem a -> Permutation sem a
noPerm :: Permutation sem ()
permWithDefault :: a -> sem a -> Permutation sem a
optionalPerm ::
- Eitherable sem => IsoFunctor sem => Permutable sem =>
- sem a -> Permutation sem (Maybe a)
+ Eitherable sem =>
+ IsoFunctor sem =>
+ Permutable sem =>
+ sem a ->
+ Permutation sem (Maybe a)
optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
(<&>) ::
Permutation sem (a, b)
x <&> y = perm x <.> y
infixr 4 <&>
-{-# INLINE (<&>) #-}
+{-# INLINE (<&>) #-}
(<?&>) ::
Eitherable sem =>
ProductFunctor (Permutation sem) =>
sem a ->
Permutation sem b ->
- Permutation sem ([a],b)
+ Permutation sem ([a], b)
x <*&> y = permWithDefault [] (many1 x) <.> y
infixr 4 <*&>
{-# INLINE (<*&>) #-}
infixr 4 <+&>
{-# INLINE (<+&>) #-}
--- * Class 'Routable'
-class Routable sem where
- (<!>) :: sem a -> sem b -> sem (a, b); infixr 4 <!>
- (<!>) = liftDerived2 (<!>)
- default (<!>) ::
- FromDerived2 Routable sem =>
- sem a -> sem b -> sem (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'
class Voidable sem where
-- | Useful to supply @(a)@ to a @(sem)@ consuming @(a)@,
void = liftDerived1 Fun.. void
default void ::
FromDerived1 Voidable sem =>
- a -> sem a -> sem ()
+ a ->
+ sem a ->
+ sem ()
-- * Class 'Substractable'
class Substractable sem where
- (<->) :: sem a -> sem b -> sem a; infixr 3 <->
+ (<->) :: sem a -> sem b -> sem a
+ infixr 3 <->
(<->) = liftDerived2 (<->)
default (<->) ::
FromDerived2 Substractable sem =>
- sem a -> sem b -> sem a
+ sem a ->
+ sem b ->
+ sem a