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