src/Symantic/Dityped/Algebrable.hs

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