src/Symantic/Base/Algebrable.hs

   1 module Symantic.Base.Algebrable where
   2
   3 import Data.Either (Either)
   4 import Data.Function ((.))
   5 import Data.Maybe (Maybe(..))
   6 import Data.Proxy (Proxy(..))
   7 import GHC.Generics (Generic)
   8
   9 import Symantic.Base.ADT
  10 import Symantic.Base.CurryN
  11 import Symantic.Base.Composable
  12
  13 -- | @('adt' @@SomeADT some_expr)@
  14 -- wrap/unwrap @(some_expr)@ input/output value
  15 -- to/from the Algebraic Data Type @(SomeADT)@.
  16 -- @(SomeADT)@ must have a 'Generic' instance
  17 -- (using the @DeriveGeneric@ language extension to GHC).
  18 adt ::
  19  forall adt repr k.
  20  Dimapable repr =>
  21  Generic adt =>
  22  RepOfEoT adt =>
  23  EoTOfRep adt =>
  24  repr (EoT (ADT adt) -> k) k ->
  25  repr (adt -> k) k
  26 adt = dimap adtOfeot eotOfadt
  27
  28 -- * Class 'Tupable'
  29 class Tupable repr where
  30   default (<:>) :: Transformable repr => Tupable (UnTrans repr) =>
  31            repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k
  32   (<:>) :: repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k
  33   x <:> y = noTrans (unTrans x <:> unTrans y)
  34 infixr 4 <:>
  35
  36 -- ** Class 'Unitable'
  37 class Unitable repr where
  38   default unit :: Transformable repr => Unitable (UnTrans repr) =>
  39           repr (() -> k) k
  40   unit :: repr (() -> k) k
  41   unit = noTrans unit
  42
  43 -- ** Class 'Constant'
  44 class Constant repr where
  45   default constant :: Transformable repr => Constant (UnTrans repr) =>
  46               a -> repr (a -> k) k
  47   constant :: a -> repr (a -> k) k
  48   constant = noTrans . constant
  49
  50 -- * Class 'Eitherable'
  51 class Eitherable repr where
  52   default (<+>) :: Transformable repr => Eitherable (UnTrans repr) =>
  53            repr (a->k) k -> repr (b->k) k -> repr (Either a b -> k) k
  54   (<+>) :: repr (a->k) k -> repr (b->k) k -> repr (Either a b->k) k
  55   x <+> y = noTrans (unTrans x <+> unTrans y)
  56 -- NOTE: yes infixr, not infixl like <|>,
  57 -- in order to run left-most checks first.
  58 infixr 3 <+>
  59
  60 -- ** Class 'Emptyable'
  61 class Emptyable repr where
  62   default empty :: Transformable repr => Emptyable (UnTrans repr) =>
  63            repr k k
  64   empty :: repr k k
  65   empty = noTrans empty
  66
  67 -- ** Class 'Optionable'
  68 class Optionable repr where
  69   default option :: Transformable repr => Optionable (UnTrans repr) =>
  70             repr k k -> repr k k
  71   option :: repr k k -> repr k k
  72   option = noTrans . option . unTrans
  73   default optional :: Transformable repr => Optionable (UnTrans repr) =>
  74               repr (a->k) k -> repr (Maybe a->k) k
  75   optional :: repr (a->k) k -> repr (Maybe a->k) k
  76   optional = noTrans . optional . unTrans
  77
  78 -- * Class 'Repeatable'
  79 class Repeatable repr where
  80   default many0 :: Transformable repr => Repeatable (UnTrans repr) =>
  81            repr (a->k) k -> repr ([a]->k) k
  82   many0 :: repr (a->k) k -> repr ([a]->k) k
  83   many0 = noTrans . many0 . unTrans
  84   default many1 :: Transformable repr => Repeatable (UnTrans repr) =>
  85            repr (a->k) k -> repr ([a]->k) k
  86   many1 :: repr (a->k) k -> repr ([a]->k) k
  87   many1 = noTrans . many1 . unTrans
  88
  89 -- * Class 'Substractable'
  90 class Substractable repr where
  91   default (<->) :: Transformable repr => Substractable (UnTrans repr) =>
  92            repr a k -> repr k' k' -> repr a k
  93   (<->) :: repr a k -> repr k' k' -> repr a k
  94   x <-> y = noTrans (unTrans x <-> unTrans y)
  95 infixr 3 <->
  96
  97 -- * Class 'Dicurryable'
  98 class Dicurryable repr where
  99   dicurry ::
 100    CurryN args =>
 101    proxy args ->
 102    (args-..->r) -> -- construction
 103    (r->Tuples args) -> -- destruction
 104    repr (args-..->k) k ->
 105    repr (r->k) k
 106   default dicurry ::
 107    Transformable repr =>
 108    Dicurryable (UnTrans repr) =>
 109    CurryN args =>
 110    proxy args ->
 111    (args-..->r) ->
 112    (r->Tuples args) ->
 113    repr (args-..->k) k ->
 114    repr (r->k) k
 115   dicurry args constr destr =
 116     noTrans . dicurry args constr destr . unTrans
 117
 118 construct ::
 119  forall args a k repr.
 120  Dicurryable repr =>
 121  Generic a =>
 122  EoTOfRep a =>
 123  CurryN args =>
 124  Tuples args ~ EoT (ADT a) =>
 125  (args ~ Args (args-..->a)) =>
 126  (args-..->a) ->
 127  repr (args-..->k) k ->
 128  repr (a -> k) k
 129 construct f = dicurry (Proxy::Proxy args) f eotOfadt