src/Symantic/Syntaxes/Classes.hs

   1 -- For ifSemantic
   2 {-# LANGUAGE AllowAmbiguousTypes #-}
   3 -- For Syntax
   4 {-# LANGUAGE DataKinds #-}
   5 -- For (:!:)
   6 {-# LANGUAGE PatternSynonyms #-}
   7 -- For ifSemantic
   8 {-# LANGUAGE RankNTypes #-}
   9 -- For Permutation
  10 {-# LANGUAGE TypeFamilyDependencies #-}
  11 -- For Permutation
  12 {-# LANGUAGE UndecidableInstances #-}
  13
  14 -- | Combinators in this module conflict with usual ones from the @Prelude@
  15 -- hence they are meant to be imported either explicitely or qualified.
  16 module Symantic.Syntaxes.Classes where
  17
  18 import Control.Category qualified as Cat
  19 import Data.Bool (Bool (..))
  20 import Data.Char (Char)
  21 import Data.Either (Either (..))
  22 import Data.Eq (Eq)
  23 import Data.Function qualified as Fun
  24 import Data.Int (Int)
  25 import Data.Kind (Constraint)
  26 import Data.Maybe (Maybe (..), fromJust)
  27 import Data.Proxy (Proxy (..))
  28 import Data.Semigroup (Semigroup)
  29 import Data.String (String)
  30 import Data.Tuple qualified as Tuple
  31 import GHC.Generics (Generic)
  32 import Numeric.Natural (Natural)
  33
  34 import Symantic.Syntaxes.CurryN
  35 import Symantic.Syntaxes.Derive
  36 import Symantic.Syntaxes.EithersOfTuples
  37
  38 -- * Type 'Syntax'
  39 type Syntax = Semantic -> Constraint
  40
  41 -- ** Type family 'Syntaxes'
  42
  43 -- | Merge several 'Syntax'es into a single one.
  44 --
  45 -- Useful in 'IfSemantic' or 'All'.
  46 type family Syntaxes (syns :: [Syntax]) (sem :: Semantic) :: Constraint where
  47   Syntaxes '[] sem = (() :: Constraint)
  48   Syntaxes (syn ': syns) sem = ((syn sem, Syntaxes syns sem) :: Constraint)
  49
  50 -- * Class 'Abstractable'
  51 class Abstractable sem where
  52   -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
  53   lam :: (sem a -> sem b) -> sem (a -> b)
  54   lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))
  55   default lam ::
  56     FromDerived Abstractable sem =>
  57     Derivable sem =>
  58     (sem a -> sem b) ->
  59     sem (a -> b)
  60
  61 -- ** Class 'Abstractable1'
  62 class Abstractable1 sem where
  63   -- | Like 'lam' but whose argument must be used only once,
  64   -- hence safe to beta-reduce (inline) without duplicating work.
  65   lam1 :: (sem a -> sem b) -> sem (a -> b)
  66   lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))
  67   default lam1 ::
  68     FromDerived Abstractable1 sem =>
  69     Derivable sem =>
  70     (sem a -> sem b) ->
  71     sem (a -> b)
  72
  73 -- ** Class 'Varable'
  74 class Varable sem where
  75   -- | Mark the use of a variable.
  76   var :: sem a -> sem a
  77   var = liftDerived1 var
  78   default var :: FromDerived1 Varable sem => sem a -> sem a
  79
  80 -- ** Class 'Unabstractable'
  81 class Unabstractable sem where
  82   -- | Application, aka. unabstract.
  83   (.@) :: sem (a -> b) -> sem a -> sem b
  84
  85   infixl 9 .@
  86   (.@) = liftDerived2 (.@)
  87   default (.@) ::
  88     FromDerived2 Unabstractable sem =>
  89     sem (a -> b) ->
  90     sem a ->
  91     sem b
  92
  93 -- ** Class 'Functionable'
  94 class Functionable sem where
  95   const :: sem (a -> b -> a)
  96   flip :: sem ((a -> b -> c) -> b -> a -> c)
  97   id :: sem (a -> a)
  98   (.) :: sem ((b -> c) -> (a -> b) -> a -> c)
  99   infixr 9 .
 100   ($) :: sem ((a -> b) -> a -> b)
 101   infixr 0 $
 102   const = liftDerived const
 103   flip = liftDerived flip
 104   id = liftDerived id
 105   (.) = liftDerived (.)
 106   ($) = liftDerived ($)
 107   default const ::
 108     FromDerived Functionable sem =>
 109     sem (a -> b -> a)
 110   default flip ::
 111     FromDerived Functionable sem =>
 112     sem ((a -> b -> c) -> b -> a -> c)
 113   default id ::
 114     FromDerived Functionable sem =>
 115     sem (a -> a)
 116   default (.) ::
 117     FromDerived Functionable sem =>
 118     sem ((b -> c) -> (a -> b) -> a -> c)
 119   default ($) ::
 120     FromDerived Functionable sem =>
 121     sem ((a -> b) -> a -> b)
 122
 123 -- * Class 'Anythingable'
 124 class Anythingable sem where
 125   anything :: sem a -> sem a
 126   anything = Fun.id
 127
 128 -- * Class 'Bottomable'
 129 class Bottomable sem where
 130   bottom :: sem a
 131
 132 -- * Class 'Constantable'
 133 class Constantable c sem where
 134   constant :: c -> sem c
 135   constant = liftDerived Fun.. constant
 136   default constant ::
 137     FromDerived (Constantable c) sem =>
 138     c ->
 139     sem c
 140
 141 -- * Class 'Eitherable'
 142 class Eitherable sem where
 143   either :: sem ((l -> a) -> (r -> a) -> Either l r -> a)
 144   left :: sem (l -> Either l r)
 145   right :: sem (r -> Either l r)
 146   either = liftDerived either
 147   left = liftDerived left
 148   right = liftDerived right
 149   default either ::
 150     FromDerived Eitherable sem =>
 151     sem ((l -> a) -> (r -> a) -> Either l r -> a)
 152   default left ::
 153     FromDerived Eitherable sem =>
 154     sem (l -> Either l r)
 155   default right ::
 156     FromDerived Eitherable sem =>
 157     sem (r -> Either l r)
 158
 159 -- * Class 'Equalable'
 160 class Equalable sem where
 161   equal :: Eq a => sem (a -> a -> Bool)
 162   equal = liftDerived equal
 163   default equal ::
 164     FromDerived Equalable sem =>
 165     Eq a =>
 166     sem (a -> a -> Bool)
 167
 168 infix 4 `equal`, ==
 169 (==) ::
 170   Abstractable sem =>
 171   Unabstractable sem =>
 172   Equalable sem =>
 173   Eq a =>
 174   sem a ->
 175   sem a ->
 176   sem Bool
 177 (==) x y = equal .@ x .@ y
 178
 179 -- * Class 'IfThenElseable'
 180 class IfThenElseable sem where
 181   ifThenElse :: sem Bool -> sem a -> sem a -> sem a
 182   ifThenElse = liftDerived3 ifThenElse
 183   default ifThenElse ::
 184     FromDerived3 IfThenElseable sem =>
 185     sem Bool ->
 186     sem a ->
 187     sem a ->
 188     sem a
 189
 190 -- * Class 'Inferable'
 191 class Inferable a sem where
 192   infer :: sem a
 193   default infer :: FromDerived (Inferable a) sem => sem a
 194   infer = liftDerived infer
 195
 196 unit :: Inferable () sem => sem ()
 197 unit = infer
 198 bool :: Inferable Bool sem => sem Bool
 199 bool = infer
 200 char :: Inferable Char sem => sem Char
 201 char = infer
 202 int :: Inferable Int sem => sem Int
 203 int = infer
 204 natural :: Inferable Natural sem => sem Natural
 205 natural = infer
 206 string :: Inferable String sem => sem String
 207 string = infer
 208
 209 -- * Class 'Listable'
 210 class Listable sem where
 211   cons :: sem (a -> [a] -> [a])
 212   nil :: sem [a]
 213   cons = liftDerived cons
 214   nil = liftDerived nil
 215   default cons ::
 216     FromDerived Listable sem =>
 217     sem (a -> [a] -> [a])
 218   default nil ::
 219     FromDerived Listable sem =>
 220     sem [a]
 221
 222 -- * Class 'Maybeable'
 223 class Maybeable sem where
 224   nothing :: sem (Maybe a)
 225   just :: sem (a -> Maybe a)
 226   nothing = liftDerived nothing
 227   just = liftDerived just
 228   default nothing ::
 229     FromDerived Maybeable sem =>
 230     sem (Maybe a)
 231   default just ::
 232     FromDerived Maybeable sem =>
 233     sem (a -> Maybe a)
 234
 235 -- * Class 'IsoFunctor'
 236 class IsoFunctor sem where
 237   (<%>) :: Iso a b -> sem a -> sem b
 238   infixl 4 <%>
 239   (<%>) iso = liftDerived1 (iso <%>)
 240   default (<%>) ::
 241     FromDerived1 IsoFunctor sem =>
 242     Iso a b ->
 243     sem a ->
 244     sem b
 245
 246 -- ** Type 'Iso'
 247 data Iso a b = Iso {a2b :: a -> b, b2a :: b -> a}
 248 instance Cat.Category Iso where
 249   id = Iso Cat.id Cat.id
 250   f . g = Iso (a2b f Cat.. a2b g) (b2a g Cat.. b2a f)
 251
 252 -- * Class 'ProductFunctor'
 253
 254 -- | Beware that this is an @infixr@,
 255 -- not @infixl@ like 'Control.Applicative.<*>';
 256 -- this is to follow what is expected by 'ADT'.
 257 class ProductFunctor sem where
 258   (<.>) :: sem a -> sem b -> sem (a, b)
 259   infixr 4 <.>
 260   (<.>) = liftDerived2 (<.>)
 261   default (<.>) ::
 262     FromDerived2 ProductFunctor sem =>
 263     sem a ->
 264     sem b ->
 265     sem (a, b)
 266   (<.) :: sem a -> sem () -> sem a
 267   infixr 4 <.
 268   ra <. rb = Iso Tuple.fst (,()) <%> (ra <.> rb)
 269   default (<.) :: IsoFunctor sem => sem a -> sem () -> sem a
 270   (.>) :: sem () -> sem a -> sem a
 271   infixr 4 .>
 272   ra .> rb = Iso Tuple.snd ((),) <%> (ra <.> rb)
 273   default (.>) :: IsoFunctor sem => sem () -> sem a -> sem a
 274
 275 -- * Class 'SumFunctor'
 276
 277 -- | Beware that this is an @infixr@,
 278 -- not @infixl@ like 'Control.Applicative.<|>';
 279 -- this is to follow what is expected by 'ADT'.
 280 class SumFunctor sem where
 281   (<+>) :: sem a -> sem b -> sem (Either a b)
 282   infixr 3 <+>
 283   (<+>) = liftDerived2 (<+>)
 284   default (<+>) ::
 285     FromDerived2 SumFunctor sem =>
 286     sem a ->
 287     sem b ->
 288     sem (Either a b)
 289
 290 -- | Like @(,)@ but @infixr@.
 291 -- Mostly useful for clarity when using 'SumFunctor'.
 292 pattern (:!:) :: a -> b -> (a, b)
 293 pattern a :!: b <-
 294   (a, b)
 295   where
 296     a :!: b = (a, b)
 297
 298 infixr 4 :!:
 299 {-# COMPLETE (:!:) #-}
 300
 301 -- * Class 'AlternativeFunctor'
 302
 303 -- | Beware that this is an @infixr@,
 304 -- not @infixl@ like 'Control.Applicative.<|>';
 305 -- this is to follow what is expected by 'ADT'.
 306 class AlternativeFunctor sem where
 307   (<|>) :: sem a -> sem a -> sem a
 308   infixr 3 <|>
 309   (<|>) = liftDerived2 (<|>)
 310   default (<|>) ::
 311     FromDerived2 AlternativeFunctor sem =>
 312     sem a ->
 313     sem a ->
 314     sem a
 315
 316 -- * Class 'Dicurryable'
 317 class Dicurryable sem where
 318   dicurry ::
 319     CurryN args =>
 320     proxy args ->
 321     (args -..-> a) -> -- construction
 322     (a -> Tuples args) -> -- destruction
 323     sem (Tuples args) ->
 324     sem a
 325   dicurry args constr destr = liftDerived1 (dicurry args constr destr)
 326   default dicurry ::
 327     FromDerived1 Dicurryable sem =>
 328     CurryN args =>
 329     proxy args ->
 330     (args -..-> a) ->
 331     (a -> Tuples args) ->
 332     sem (Tuples args) ->
 333     sem a
 334
 335 construct ::
 336   forall args a sem.
 337   Dicurryable sem =>
 338   Generic a =>
 339   EoTOfRep a =>
 340   CurryN args =>
 341   Tuples args ~ EoT (ADT a) =>
 342   (args ~ Args (args -..-> a)) =>
 343   (args -..-> a) ->
 344   sem (Tuples args) ->
 345   sem a
 346 construct f = dicurry (Proxy :: Proxy args) f eotOfadt
 347
 348 -- * Class 'Dataable'
 349
 350 -- | Enable the contruction or deconstruction
 351 -- of an 'ADT' (algebraic data type).
 352 class Dataable a sem where
 353   dataType :: sem (EoT (ADT a)) -> sem a
 354   default dataType ::
 355     Generic a =>
 356     RepOfEoT a =>
 357     EoTOfRep a =>
 358     IsoFunctor sem =>
 359     sem (EoT (ADT a)) ->
 360     sem a
 361   dataType = (<%>) (Iso adtOfeot eotOfadt)
 362
 363 -- * Class 'IfSemantic'
 364
 365 -- | 'IfSemantic' enables to change the 'Syntax' for a specific 'Semantic'.
 366 --
 367 -- Useful when a 'Semantic' does not implement some 'Syntax'es used by other 'Semantic's.
 368 class
 369   IfSemantic
 370     (thenSyntaxes :: [Syntax])
 371     (elseSyntaxes :: [Syntax])
 372     thenSemantic
 373     elseSemantic
 374   where
 375   ifSemantic ::
 376     (Syntaxes thenSyntaxes thenSemantic => thenSemantic a) ->
 377     (Syntaxes elseSyntaxes elseSemantic => elseSemantic a) ->
 378     elseSemantic a
 379
 380 instance
 381   {-# OVERLAPPING #-}
 382   Syntaxes thenSyntaxes thenSemantic =>
 383   IfSemantic thenSyntaxes elseSyntaxes thenSemantic thenSemantic
 384   where
 385   ifSemantic thenSyntax _elseSyntax = thenSyntax
 386 instance
 387   Syntaxes elseSyntaxes elseSemantic =>
 388   IfSemantic thenSyntaxes elseSyntaxes thenSemantic elseSemantic
 389   where
 390   ifSemantic _thenSyntax elseSyntax = elseSyntax
 391
 392 -- * Class 'Monoidable'
 393 class
 394   ( Emptyable sem
 395   , Semigroupable sem
 396   ) =>
 397   Monoidable sem
 398 instance
 399   ( Emptyable sem
 400   , Semigroupable sem
 401   ) =>
 402   Monoidable sem
 403
 404 -- ** Class 'Emptyable'
 405 class Emptyable sem where
 406   empty :: sem a
 407   empty = liftDerived empty
 408   default empty ::
 409     FromDerived Emptyable sem =>
 410     sem a
 411
 412 -- ** Class 'Semigroupable'
 413 class Semigroupable sem where
 414   concat :: Semigroup a => sem (a -> a -> a)
 415   concat = liftDerived concat
 416   default concat ::
 417     FromDerived Semigroupable sem =>
 418     Semigroup a =>
 419     sem (a -> a -> a)
 420
 421 infixr 6 `concat`, <>
 422 (<>) ::
 423   Abstractable sem =>
 424   Unabstractable sem =>
 425   Semigroupable sem =>
 426   Semigroup a =>
 427   sem a ->
 428   sem a ->
 429   sem a
 430 (<>) x y = concat .@ x .@ y
 431
 432 -- ** Class 'Optionable'
 433 class Optionable sem where
 434   optional :: sem a -> sem (Maybe a)
 435   optional = liftDerived1 optional
 436   default optional ::
 437     FromDerived1 Optionable sem =>
 438     sem a ->
 439     sem (Maybe a)
 440
 441 -- * Class 'Repeatable'
 442 class Repeatable sem where
 443   many0 :: sem a -> sem [a]
 444   many1 :: sem a -> sem [a]
 445   many0 = liftDerived1 many0
 446   many1 = liftDerived1 many1
 447   default many0 ::
 448     FromDerived1 Repeatable sem =>
 449     sem a ->
 450     sem [a]
 451   default many1 ::
 452     FromDerived1 Repeatable sem =>
 453     sem a ->
 454     sem [a]
 455
 456 -- | Alias to 'many0'.
 457 many :: Repeatable sem => sem a -> sem [a]
 458 many = many0
 459
 460 -- | Alias to 'many1'.
 461 some :: Repeatable sem => sem a -> sem [a]
 462 some = many1
 463
 464 -- * Class 'Permutable'
 465 class Permutable sem where
 466   -- Use @TypeFamilyDependencies@ to help type-inference infer @(sem)@.
 467   type Permutation (sem :: Semantic) = (r :: Semantic) | r -> sem
 468   type Permutation sem = Permutation (Derived sem)
 469   permutable :: Permutation sem a -> sem a
 470   perm :: sem a -> Permutation sem a
 471   noPerm :: Permutation sem ()
 472   permWithDefault :: a -> sem a -> Permutation sem a
 473   optionalPerm ::
 474     Eitherable sem =>
 475     IsoFunctor sem =>
 476     Permutable sem =>
 477     sem a ->
 478     Permutation sem (Maybe a)
 479   optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
 480
 481 (<&>) ::
 482   Permutable sem =>
 483   ProductFunctor (Permutation sem) =>
 484   sem a ->
 485   Permutation sem b ->
 486   Permutation sem (a, b)
 487 x <&> y = perm x <.> y
 488 infixr 4 <&>
 489 {-# INLINE (<&>) #-}
 490
 491 (<?&>) ::
 492   Eitherable sem =>
 493   IsoFunctor sem =>
 494   Permutable sem =>
 495   ProductFunctor (Permutation sem) =>
 496   sem a ->
 497   Permutation sem b ->
 498   Permutation sem (Maybe a, b)
 499 x <?&> y = optionalPerm x <.> y
 500 infixr 4 <?&>
 501 {-# INLINE (<?&>) #-}
 502
 503 (<*&>) ::
 504   Eitherable sem =>
 505   Repeatable sem =>
 506   IsoFunctor sem =>
 507   Permutable sem =>
 508   ProductFunctor (Permutation sem) =>
 509   sem a ->
 510   Permutation sem b ->
 511   Permutation sem ([a], b)
 512 x <*&> y = permWithDefault [] (many1 x) <.> y
 513 infixr 4 <*&>
 514 {-# INLINE (<*&>) #-}
 515
 516 (<+&>) ::
 517   Eitherable sem =>
 518   Repeatable sem =>
 519   IsoFunctor sem =>
 520   Permutable sem =>
 521   ProductFunctor (Permutation sem) =>
 522   sem a ->
 523   Permutation sem b ->
 524   Permutation sem ([a], b)
 525 x <+&> y = perm (many1 x) <.> y
 526 infixr 4 <+&>
 527 {-# INLINE (<+&>) #-}
 528
 529 -- * Class 'Voidable'
 530 class Voidable sem where
 531   -- | Useful to supply @(a)@ to a @(sem)@ consuming @(a)@,
 532   -- for example in the format of a printing interpreter.
 533   void :: a -> sem a -> sem ()
 534   void = liftDerived1 Fun.. void
 535   default void ::
 536     FromDerived1 Voidable sem =>
 537     a ->
 538     sem a ->
 539     sem ()
 540
 541 -- * Class 'Substractable'
 542 class Substractable sem where
 543   (<->) :: sem a -> sem b -> sem a
 544   infixr 3 <->
 545   (<->) = liftDerived2 (<->)
 546   default (<->) ::
 547     FromDerived2 Substractable sem =>
 548     sem a ->
 549     sem b ->
 550     sem a