src/Symantic/Syntaxes/Classes.hs

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