doc: rename type variable `able` to `syn`
[haskell/symantic-base.git] / src / Symantic / Syntaxes / Classes.hs
index 9cbbe7fdbed741b08d595066aaa5d86274ff53bc..9d7bb422bfceaa0d9d383d5ae35e61d73e349b50 100644 (file)
@@ -1,35 +1,45 @@
-{-# 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'.
@@ -37,44 +47,56 @@ type family Syntaxes (syns :: [Syntax]) (sem :: Semantic) :: Constraint where
   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
@@ -88,13 +110,13 @@ class Functionable sem where
     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
@@ -111,14 +133,20 @@ class Constantable c 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)
@@ -132,12 +160,17 @@ class Equalable sem where
   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'
@@ -146,7 +179,10 @@ class IfThenElseable sem where
   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
@@ -195,64 +231,92 @@ class Maybeable 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)
@@ -260,8 +324,8 @@ class Dicurryable sem where
     FromDerived1 Dicurryable sem =>
     CurryN args =>
     proxy args ->
-    (args-..->a) ->
-    (a->Tuples args) ->
+    (args -..-> a) ->
+    (a -> Tuples args) ->
     sem (Tuples args) ->
     sem a
 
@@ -272,23 +336,29 @@ construct ::
   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.
@@ -303,25 +373,30 @@ class
     (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
@@ -342,8 +417,12 @@ class Semigroupable 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'
@@ -352,7 +431,8 @@ class Optionable sem where
   optional = liftDerived1 optional
   default optional ::
     FromDerived1 Optionable sem =>
-    sem a -> sem (Maybe a)
+    sem a ->
+    sem (Maybe a)
 
 -- * Class 'Repeatable'
 class Repeatable sem where
@@ -362,10 +442,12 @@ 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]
@@ -378,15 +460,18 @@ some = many1
 -- * 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)
 
 (<&>) ::
@@ -397,7 +482,7 @@ class Permutable sem where
   Permutation sem (a, b)
 x <&> y = perm x <.> y
 infixr 4 <&>
-{-# INLINE (<&>)  #-}
+{-# INLINE (<&>) #-}
 
 (<?&>) ::
   Eitherable sem =>
@@ -419,7 +504,7 @@ infixr 4 <?&>
   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 (<*&>) #-}
@@ -437,21 +522,6 @@ x <+&> y = perm (many1 x) <.> y
 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)@,
@@ -460,12 +530,17 @@ class Voidable sem where
   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