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 repr where
  46   -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
  47   lam :: (repr a -> repr b) -> repr (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 :: (repr a -> repr b) -> repr (a->b)
  51   var :: repr a -> repr a
  52   -- | Application, aka. unabstract.
  53   (.@) :: repr (a->b) -> repr a -> repr 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 repr => Derivable repr =>
  60     (repr a -> repr b) -> repr (a->b)
  61   default lam1 ::
  62     FromDerived Abstractable repr => Derivable repr =>
  63     (repr a -> repr b) -> repr (a->b)
  64   default var ::
  65     FromDerived1 Abstractable repr =>
  66     repr a -> repr a
  67   default (.@) ::
  68     FromDerived2 Abstractable repr =>
  69     repr (a->b) -> repr a -> repr b
  70
  71 -- ** Class 'Functionable'
  72 class Functionable repr where
  73   const :: repr (a -> b -> a)
  74   flip :: repr ((a -> b -> c) -> b -> a -> c)
  75   id :: repr (a->a)
  76   (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
  77   ($) :: repr ((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 repr =>
  85     repr (a -> b -> a)
  86   default flip ::
  87     FromDerived Functionable repr =>
  88     repr ((a -> b -> c) -> b -> a -> c)
  89   default id ::
  90     FromDerived Functionable repr =>
  91     repr (a->a)
  92   default (.) ::
  93     FromDerived Functionable repr =>
  94     repr ((b->c) -> (a->b) -> a -> c)
  95   default ($) ::
  96     FromDerived Functionable repr =>
  97     repr ((a->b) -> a -> b)
  98
  99 -- * Class 'Anythingable'
 100 class Anythingable repr where
 101   anything :: repr a -> repr a
 102   anything = Fun.id
 103
 104 -- * Class 'Bottomable'
 105 class Bottomable repr where
 106   bottom :: repr a
 107
 108 -- * Class 'Constantable'
 109 class Constantable c repr where
 110   constant :: c -> repr c
 111   constant = liftDerived Fun.. constant
 112   default constant ::
 113     FromDerived (Constantable c) repr =>
 114     c -> repr c
 115
 116 -- * Class 'Eitherable'
 117 class Eitherable repr where
 118   left :: repr (l -> Either l r)
 119   right :: repr (r -> Either l r)
 120   left = liftDerived left
 121   right = liftDerived right
 122   default left ::
 123     FromDerived Eitherable repr =>
 124     repr (l -> Either l r)
 125   default right ::
 126     FromDerived Eitherable repr =>
 127     repr (r -> Either l r)
 128
 129 -- * Class 'Equalable'
 130 class Equalable repr where
 131   equal :: Eq a => repr (a -> a -> Bool)
 132   equal = liftDerived equal
 133   default equal ::
 134     FromDerived Equalable repr =>
 135     Eq a => repr (a -> a -> Bool)
 136
 137 infix 4 `equal`, ==
 138 (==) ::
 139   Abstractable repr => Equalable repr => Eq a =>
 140   repr a -> repr a -> repr Bool
 141 (==) x y = equal .@ x .@ y
 142
 143 -- * Class 'IfThenElseable'
 144 class IfThenElseable repr where
 145   ifThenElse :: repr Bool -> repr a -> repr a -> repr a
 146   ifThenElse = liftDerived3 ifThenElse
 147   default ifThenElse ::
 148     FromDerived3 IfThenElseable repr =>
 149     repr Bool -> repr a -> repr a -> repr a
 150
 151 -- * Class 'Inferable'
 152 class Inferable a repr where
 153   infer :: repr a
 154   default infer :: FromDerived (Inferable a) repr => repr a
 155   infer = liftDerived infer
 156
 157 unit :: Inferable () repr => repr ()
 158 unit = infer
 159 bool :: Inferable Bool repr => repr Bool
 160 bool = infer
 161 char :: Inferable Char repr => repr Char
 162 char = infer
 163 int :: Inferable Int repr => repr Int
 164 int = infer
 165 natural :: Inferable Natural repr => repr Natural
 166 natural = infer
 167 string :: Inferable String repr => repr String
 168 string = infer
 169
 170 -- * Class 'Listable'
 171 class Listable repr where
 172   cons :: repr (a -> [a] -> [a])
 173   nil :: repr [a]
 174   cons = liftDerived cons
 175   nil = liftDerived nil
 176   default cons ::
 177     FromDerived Listable repr =>
 178     repr (a -> [a] -> [a])
 179   default nil ::
 180     FromDerived Listable repr =>
 181     repr [a]
 182
 183 -- * Class 'Maybeable'
 184 class Maybeable repr where
 185   nothing :: repr (Maybe a)
 186   just :: repr (a -> Maybe a)
 187   nothing = liftDerived nothing
 188   just = liftDerived just
 189   default nothing ::
 190     FromDerived Maybeable repr =>
 191     repr (Maybe a)
 192   default just ::
 193     FromDerived Maybeable repr =>
 194     repr (a -> Maybe a)
 195
 196 -- * Class 'IsoFunctor'
 197 class IsoFunctor repr where
 198   (<%>) :: Iso a b -> repr a -> repr b; infixl 4 <%>
 199   (<%>) iso = liftDerived1 (iso <%>)
 200   default (<%>) ::
 201     FromDerived1 IsoFunctor repr =>
 202     Iso a b -> repr a -> repr 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 repr where
 215   (<.>) :: repr a -> repr b -> repr (a, b); infixr 4 <.>
 216   (<.>) = liftDerived2 (<.>)
 217   default (<.>) ::
 218     FromDerived2 ProductFunctor repr =>
 219     repr a -> repr b -> repr (a, b)
 220   (<.) :: repr a -> repr () -> repr a; infixr 4 <.
 221   ra <. rb = Iso Tuple.fst (, ()) <%> (ra <.> rb)
 222   default (<.) :: IsoFunctor repr => repr a -> repr () -> repr a
 223   (.>) :: repr () -> repr a -> repr a; infixr 4 .>
 224   ra .> rb = Iso Tuple.snd (() ,) <%> (ra <.> rb)
 225   default (.>) :: IsoFunctor repr => repr () -> repr a -> repr 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 repr where
 232   (<+>) :: repr a -> repr b -> repr (Either a b); infixr 3 <+>
 233   (<+>) = liftDerived2 (<+>)
 234   default (<+>) ::
 235     FromDerived2 SumFunctor repr =>
 236     repr a -> repr b -> repr (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 repr where
 243   (<|>) :: repr a -> repr a -> repr a; infixr 3 <|>
 244   (<|>) = liftDerived2 (<|>)
 245   default (<|>) ::
 246     FromDerived2 AlternativeFunctor repr =>
 247     repr a -> repr a -> repr a
 248
 249 -- * Class 'Dicurryable'
 250 class Dicurryable repr where
 251   dicurry ::
 252     CurryN args =>
 253     proxy args ->
 254     (args-..->a) -> -- construction
 255     (a->Tuples args) -> -- destruction
 256     repr (Tuples args) ->
 257     repr a
 258   dicurry args constr destr = liftDerived1 (dicurry args constr destr)
 259   default dicurry ::
 260     FromDerived1 Dicurryable repr =>
 261     CurryN args =>
 262     proxy args ->
 263     (args-..->a) ->
 264     (a->Tuples args) ->
 265     repr (Tuples args) ->
 266     repr a
 267
 268 construct ::
 269   forall args a repr.
 270   Dicurryable repr =>
 271   Generic a =>
 272   EoTOfRep a =>
 273   CurryN args =>
 274   Tuples args ~ EoT (ADT a) =>
 275   (args ~ Args (args-..->a)) =>
 276   (args-..->a) ->
 277   repr (Tuples args) ->
 278   repr a
 279 construct f = dicurry (Proxy::Proxy args) f eotOfadt
 280
 281 adt ::
 282   forall adt repr.
 283   IsoFunctor repr =>
 284   Generic adt =>
 285   RepOfEoT adt =>
 286   EoTOfRep adt =>
 287   repr (EoT (ADT adt)) ->
 288   repr 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 repr
 319   , Semigroupable repr
 320   ) => Monoidable repr
 321 instance
 322   ( Emptyable repr
 323   , Semigroupable repr
 324   ) => Monoidable repr
 325
 326 -- ** Class 'Emptyable'
 327 class Emptyable repr where
 328   empty :: repr a
 329   empty = liftDerived empty
 330   default empty ::
 331     FromDerived Emptyable repr =>
 332     repr a
 333
 334 -- ** Class 'Semigroupable'
 335 class Semigroupable repr where
 336   concat :: Semigroup a => repr (a -> a -> a)
 337   concat = liftDerived concat
 338   default concat ::
 339     FromDerived Semigroupable repr =>
 340     Semigroup a =>
 341     repr (a -> a -> a)
 342
 343 infixr 6 `concat`, <>
 344 (<>) ::
 345   Abstractable repr => Semigroupable repr => Semigroup a =>
 346   repr a -> repr a -> repr a
 347 (<>) x y = concat .@ x .@ y
 348
 349 -- ** Class 'Optionable'
 350 class Optionable repr where
 351   optional :: repr a -> repr (Maybe a)
 352   optional = liftDerived1 optional
 353   default optional ::
 354     FromDerived1 Optionable repr =>
 355     repr a -> repr (Maybe a)
 356
 357 -- * Class 'Repeatable'
 358 class Repeatable repr where
 359   many0 :: repr a -> repr [a]
 360   many1 :: repr a -> repr [a]
 361   many0 = liftDerived1 many0
 362   many1 = liftDerived1 many1
 363   default many0 ::
 364     FromDerived1 Repeatable repr =>
 365     repr a -> repr [a]
 366   default many1 ::
 367     FromDerived1 Repeatable repr =>
 368     repr a -> repr [a]
 369
 370 -- | Alias to 'many0'.
 371 many :: Repeatable repr => repr a -> repr [a]
 372 many = many0
 373
 374 -- | Alias to 'many1'.
 375 some :: Repeatable repr => repr a -> repr [a]
 376 some = many1
 377
 378 -- * Class 'Permutable'
 379 class Permutable repr where
 380   -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
 381   type Permutation (repr:: Semantic) = (r :: Semantic) | r -> repr
 382   type Permutation repr = Permutation (Derived repr)
 383   permutable :: Permutation repr a -> repr a
 384   perm :: repr a -> Permutation repr a
 385   noPerm :: Permutation repr ()
 386   permWithDefault :: a -> repr a -> Permutation repr a
 387   optionalPerm ::
 388     Eitherable repr => IsoFunctor repr => Permutable repr =>
 389     repr a -> Permutation repr (Maybe a)
 390   optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
 391
 392 (<&>) ::
 393   Permutable repr =>
 394   ProductFunctor (Permutation repr) =>
 395   repr a ->
 396   Permutation repr b ->
 397   Permutation repr (a, b)
 398 x <&> y = perm x <.> y
 399 infixr 4 <&>
 400 {-# INLINE (<&>)  #-}
 401
 402 (<?&>) ::
 403   Eitherable repr =>
 404   IsoFunctor repr =>
 405   Permutable repr =>
 406   ProductFunctor (Permutation repr) =>
 407   repr a ->
 408   Permutation repr b ->
 409   Permutation repr (Maybe a, b)
 410 x <?&> y = optionalPerm x <.> y
 411 infixr 4 <?&>
 412 {-# INLINE (<?&>) #-}
 413
 414 (<*&>) ::
 415   Eitherable repr =>
 416   Repeatable repr =>
 417   IsoFunctor repr =>
 418   Permutable repr =>
 419   ProductFunctor (Permutation repr) =>
 420   repr a ->
 421   Permutation repr b ->
 422   Permutation repr ([a],b)
 423 x <*&> y = permWithDefault [] (many1 x) <.> y
 424 infixr 4 <*&>
 425 {-# INLINE (<*&>) #-}
 426
 427 (<+&>) ::
 428   Eitherable repr =>
 429   Repeatable repr =>
 430   IsoFunctor repr =>
 431   Permutable repr =>
 432   ProductFunctor (Permutation repr) =>
 433   repr a ->
 434   Permutation repr b ->
 435   Permutation repr ([a], b)
 436 x <+&> y = perm (many1 x) <.> y
 437 infixr 4 <+&>
 438 {-# INLINE (<+&>) #-}
 439
 440 -- * Class 'Routable'
 441 class Routable repr where
 442   (<!>) :: repr a -> repr b -> repr (a, b); infixr 4 <!>
 443   (<!>) = liftDerived2 (<!>)
 444   default (<!>) ::
 445     FromDerived2 Routable repr =>
 446     repr a -> repr b -> repr (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 repr where
 457   -- | Useful to supply @(a)@ to a @(repr)@ consuming @(a)@,
 458   -- for example in the format of a printing interpreter.
 459   void :: a -> repr a -> repr ()
 460   void = liftDerived1 Fun.. void
 461   default void ::
 462     FromDerived1 Voidable repr =>
 463     a -> repr a -> repr ()
 464
 465 -- * Class 'Substractable'
 466 class Substractable repr where
 467   (<->) :: repr a -> repr b -> repr a; infixr 3 <->
 468   (<->) = liftDerived2 (<->)
 469   default (<->) ::
 470     FromDerived2 Substractable repr =>
 471     repr a -> repr b -> repr a