src/Symantic/Dityped/Lang.hs

   1 {-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation
   2 {-# LANGUAGE UndecidableInstances #-} -- For Permutation
   3 module Symantic.Dityped.Lang where
   4
   5 import Data.Either (Either)
   6 import Data.Eq (Eq)
   7 import Data.Function ((.))
   8 import Data.Maybe (Maybe(..), fromJust)
   9 import Data.Proxy (Proxy(..))
  10 import GHC.Generics (Generic)
  11 import Text.Show (Show)
  12
  13 import Symantic.Dityped.ADT
  14 import Symantic.Dityped.CurryN
  15 import Symantic.Dityped.Derive
  16
  17 -- * Class 'Composable'
  18 class Composable repr where
  19   (<.>) :: repr a b -> repr b c -> repr a c
  20   (<.>) = liftDerived2 (<.>)
  21   default (<.>) ::
  22     FromDerived2 Composable repr =>
  23     repr a b -> repr b c -> repr a c
  24 infixr 4 <.>
  25
  26 -- ** Class 'Constant'
  27 class Constant repr where
  28   constant :: a -> repr (a -> k) k
  29   constant = liftDerived . constant
  30   default constant ::
  31     FromDerived Constant repr =>
  32     a -> repr (a -> k) k
  33
  34 -- * Class 'Dicurryable'
  35 class Dicurryable repr where
  36   dicurry ::
  37     CurryN args =>
  38     proxy args ->
  39     (args-..->r) -> -- construction
  40     (r->Tuples args) -> -- destruction
  41     repr (args-..->k) k ->
  42     repr (r->k) k
  43   dicurry args constr destr = liftDerived1 (dicurry args constr destr)
  44   default dicurry ::
  45     FromDerived1 Dicurryable repr =>
  46     CurryN args =>
  47     proxy args ->
  48     (args-..->r) ->
  49     (r->Tuples args) ->
  50     repr (args-..->k) k ->
  51     repr (r->k) k
  52
  53 construct ::
  54   forall args a k repr.
  55   Dicurryable repr =>
  56   Generic a =>
  57   EoTOfRep a =>
  58   CurryN args =>
  59   Tuples args ~ EoT (ADT a) =>
  60   (args ~ Args (args-..->a)) =>
  61   (args-..->a) ->
  62   repr (args-..->k) k ->
  63   repr (a -> k) k
  64 construct f = dicurry (Proxy::Proxy args) f eotOfadt
  65
  66 -- * Class 'Dimapable'
  67 class Dimapable repr where
  68   dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
  69   dimap a2b b2a = liftDerived1 (dimap a2b b2a)
  70   default dimap ::
  71     FromDerived1 Dimapable repr =>
  72     (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
  73
  74 -- * Class 'Eitherable'
  75 class Eitherable repr where
  76   (<+>) :: repr (a->k) k -> repr (b->k) k -> repr (Either a b->k) k
  77   (<+>) = liftDerived2 (<+>)
  78   default (<+>) ::
  79     FromDerived2 Eitherable repr =>
  80     repr (a->k) k -> repr (b->k) k -> repr (Either a b -> k) k
  81 -- NOTE: yes infixr, not infixl like <|>,
  82 -- in order to run left-most checks first.
  83 infixr 3 <+>
  84
  85 -- | @('adt' @@SomeADT some_expr)@
  86 -- wrap\/unwrap @(some_expr)@ input\/output value
  87 -- to\/from the Algebraic Data Type @(SomeADT)@.
  88 -- @(SomeADT)@ must have a 'Generic' instance
  89 -- (using the @DeriveGeneric@ language extension to GHC).
  90 adt ::
  91   forall adt repr k.
  92   Dimapable repr =>
  93   Generic adt =>
  94   RepOfEoT adt =>
  95   EoTOfRep adt =>
  96   repr (EoT (ADT adt) -> k) k ->
  97   repr (adt -> k) k
  98 adt = dimap adtOfeot eotOfadt
  99
 100 -- ** Class 'Emptyable'
 101 class Emptyable repr where
 102   empty :: repr k k
 103   empty = liftDerived empty
 104   default empty ::
 105     FromDerived Emptyable repr =>
 106     repr k k
 107
 108 -- ** Class 'Optionable'
 109 class Optionable repr where
 110   option :: repr k k -> repr k k
 111   optional :: repr (a->k) k -> repr (Maybe a->k) k
 112   option = liftDerived1 option
 113   optional = liftDerived1 optional
 114   default option ::
 115     FromDerived1 Optionable repr =>
 116     repr k k -> repr k k
 117   default optional ::
 118     FromDerived1 Optionable repr =>
 119     repr (a->k) k -> repr (Maybe a->k) k
 120
 121 -- * Class 'Permutable'
 122 class Permutable repr where
 123   -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
 124   type Permutation (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
 125   type Permutation repr = Permutation (Derived repr)
 126   permutable :: Permutation repr (a->k) k -> repr (a->k) k
 127   perm :: repr (a->k) k -> Permutation repr (a->k) k
 128   noPerm :: Permutation repr k k
 129   permWithDefault :: a -> repr (a->k) k -> Permutation repr (a->k) k
 130   optionalPerm ::
 131     Eitherable repr => Dimapable repr => Permutable repr =>
 132     repr (a->k) k -> Permutation repr (Maybe a -> k) k
 133   optionalPerm = permWithDefault Nothing . dimap Just fromJust
 134
 135 (<&>) ::
 136   Permutable repr =>
 137   Tupable (Permutation repr) =>
 138   repr (a->k) k ->
 139   Permutation repr (b->k) k ->
 140   Permutation repr ((a,b)->k) k
 141 x <&> y = perm x <:> y
 142
 143 (<?&>) ::
 144   Eitherable repr =>
 145   Dimapable repr =>
 146   Permutable repr =>
 147   Tupable (Permutation repr) =>
 148   repr (a->k) k ->
 149   Permutation repr (b->k) k ->
 150   Permutation repr ((Maybe a,b)->k) k
 151 x <?&> y = optionalPerm x <:> y
 152
 153 (<*&>) ::
 154   Eitherable repr =>
 155   Repeatable repr =>
 156   Dimapable repr =>
 157   Permutable repr =>
 158   Tupable (Permutation repr) =>
 159   repr (a->k) k ->
 160   Permutation repr (b->k) k ->
 161   Permutation repr (([a],b)->k) k
 162 x <*&> y = permWithDefault [] (many1 x) <:> y
 163
 164 (<+&>) ::
 165   Eitherable repr =>
 166   Repeatable repr =>
 167   Dimapable repr =>
 168   Permutable repr =>
 169   Tupable (Permutation repr) =>
 170   repr (a->k) k ->
 171   Permutation repr (b->k) k ->
 172   Permutation repr (([a],b)->k) k
 173 x <+&> y = perm (many1 x) <:> y
 174
 175 infixr 4 <&>
 176 infixr 4 <?&>
 177 infixr 4 <*&>
 178 infixr 4 <+&>
 179
 180 {-# INLINE (<&>)  #-}
 181 {-# INLINE (<?&>) #-}
 182 {-# INLINE (<*&>) #-}
 183 {-# INLINE (<+&>) #-}
 184
 185 -- * Class 'Repeatable'
 186 class Repeatable repr where
 187   many0 :: repr (a->k) k -> repr ([a]->k) k
 188   many1 :: repr (a->k) k -> repr ([a]->k) k
 189   many0 = liftDerived1 many0
 190   many1 = liftDerived1 many1
 191   default many0 ::
 192     FromDerived1 Repeatable repr =>
 193     repr (a->k) k -> repr ([a]->k) k
 194   default many1 ::
 195     FromDerived1 Repeatable repr =>
 196     repr (a->k) k -> repr ([a]->k) k
 197
 198 -- * Class 'Routable'
 199 class Routable repr where
 200   (<!>) :: repr a k -> repr b k -> repr (a:!:b) k
 201   (<!>) = liftDerived2 (<!>)
 202   default (<!>) ::
 203     FromDerived2 Routable repr =>
 204     repr a k -> repr b k -> repr (a:!:b) k
 205 infixr 3 <!>
 206
 207 -- ** Type (':!:')
 208 -- | Like @(,)@ but @infixr@.
 209 -- Mostly useful for clarity when using 'Routable'.
 210 data (:!:) a b = a:!:b
 211  deriving (Eq, Show)
 212 infixr 3 :!:
 213
 214 -- * Class 'Substractable'
 215 class Substractable repr where
 216   (<->) :: repr a k -> repr k' k' -> repr a k
 217   (<->) = liftDerived2 (<->)
 218   default (<->) ::
 219     FromDerived2 Substractable repr =>
 220     repr a k -> repr k' k' -> repr a k
 221 infixr 3 <->
 222
 223 -- * Class 'Tupable'
 224 class Tupable repr where
 225   (<:>) :: repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k
 226   (<:>) = liftDerived2 (<:>)
 227   default (<:>) ::
 228     FromDerived2 Tupable repr =>
 229     repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k
 230 infixr 4 <:>
 231
 232 -- ** Class 'Unitable'
 233 class Unitable repr where
 234   unit :: repr (() -> k) k
 235   unit = liftDerived unit
 236   default unit ::
 237     FromDerived Unitable repr =>
 238     repr (() -> k) k
 239
 240 -- * Class 'Voidable'
 241 class Voidable repr where
 242   default void ::
 243     FromDerived1 Voidable repr =>
 244     a -> repr (a -> b) k -> repr b k
 245   void :: a -> repr (a -> b) k -> repr b k
 246   void a = liftDerived1 (void a)