src/Symantic/Lang.hs

   1 {-# LANGUAGE DataKinds #-} -- For ReprKind
   2 {-# LANGUAGE PatternSynonyms #-} -- For (:!:)
   3 {-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation
   4 {-# LANGUAGE UndecidableInstances #-} -- For Permutation
   5 module Symantic.Lang where
   6
   7 import Data.Bool (Bool(..))
   8 import Data.Char (Char)
   9 import Data.Either (Either(..))
  10 import Data.Eq (Eq)
  11 import Data.Kind (Type)
  12 import Data.Maybe (Maybe(..), fromJust)
  13 import Data.Proxy (Proxy(..))
  14 import GHC.Generics (Generic)
  15 import qualified Data.Function as Fun
  16
  17 import Symantic.Derive
  18 import Symantic.ADT
  19 import Symantic.CurryN
  20
  21 -- * Type 'ReprKind'
  22 type ReprKind = Type -> Type
  23
  24 -- * Class 'Abstractable'
  25 class Abstractable repr where
  26   -- | Application, aka. unabstract.
  27   (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
  28   -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
  29   lam :: (repr a -> repr b) -> repr (a->b)
  30   -- | Like 'lam' but whose argument is used only once,
  31   -- hence safe to beta-reduce (inline) without duplicating work.
  32   lam1 :: (repr a -> repr b) -> repr (a->b)
  33   const :: repr (a -> b -> a)
  34   flip :: repr ((a -> b -> c) -> b -> a -> c)
  35   id :: repr (a->a)
  36   (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
  37   ($) :: repr ((a->b) -> a -> b); infixr 0 $
  38   var :: repr a -> repr a
  39   (.@) = liftDerived2 (.@)
  40   lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))
  41   lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))
  42   const = liftDerived const
  43   flip = liftDerived flip
  44   id = liftDerived id
  45   (.) = liftDerived (.)
  46   ($) = liftDerived ($)
  47   var = liftDerived1 var
  48   default (.@) ::
  49     FromDerived2 Abstractable repr =>
  50     repr (a->b) -> repr a -> repr b
  51   default lam ::
  52     FromDerived Abstractable repr => Derivable repr =>
  53     (repr a -> repr b) -> repr (a->b)
  54   default lam1 ::
  55     FromDerived Abstractable repr => Derivable repr =>
  56     (repr a -> repr b) -> repr (a->b)
  57   default const ::
  58     FromDerived Abstractable repr =>
  59     repr (a -> b -> a)
  60   default flip ::
  61     FromDerived Abstractable repr =>
  62     repr ((a -> b -> c) -> b -> a -> c)
  63   default id ::
  64     FromDerived Abstractable repr =>
  65     repr (a->a)
  66   default (.) ::
  67     FromDerived Abstractable repr =>
  68     repr ((b->c) -> (a->b) -> a -> c)
  69   default ($) ::
  70     FromDerived Abstractable repr =>
  71     repr ((a->b) -> a -> b)
  72   default var ::
  73     FromDerived1 Abstractable repr =>
  74     repr a -> repr a
  75
  76 -- * Class 'Anythingable'
  77 class Anythingable repr where
  78   anything :: repr a -> repr a
  79   anything = Fun.id
  80
  81 -- * Class 'Bottomable'
  82 class Bottomable repr where
  83   bottom :: repr a
  84
  85 -- * Class 'Constantable'
  86 class Constantable c repr where
  87   constant :: c -> repr c
  88   constant = liftDerived Fun.. constant
  89   default constant ::
  90     FromDerived (Constantable c) repr =>
  91     c -> repr c
  92
  93 bool :: Constantable Bool repr => Bool -> repr Bool
  94 bool = constant @Bool
  95 char :: Constantable Char repr => Char -> repr Char
  96 char = constant @Char
  97 unit :: Constantable () repr => repr ()
  98 unit = constant @() ()
  99
 100 -- * Class 'Eitherable'
 101 class Eitherable repr where
 102   left :: repr (l -> Either l r)
 103   right :: repr (r -> Either l r)
 104   left = liftDerived left
 105   right = liftDerived right
 106   default left ::
 107     FromDerived Eitherable repr =>
 108     repr (l -> Either l r)
 109   default right ::
 110     FromDerived Eitherable repr =>
 111     repr (r -> Either l r)
 112
 113 -- * Class 'Equalable'
 114 class Equalable repr where
 115   equal :: Eq a => repr (a -> a -> Bool)
 116   equal = liftDerived equal
 117   default equal ::
 118     FromDerived Equalable repr =>
 119     Eq a => repr (a -> a -> Bool)
 120
 121 infix 4 `equal`, ==
 122 (==) :: (Abstractable repr, Equalable repr, Eq a) => repr (a -> a -> Bool)
 123 (==) = lam (\x -> lam (\y -> equal .@ x .@ y))
 124
 125 -- * Class 'IfThenElseable'
 126 class IfThenElseable repr where
 127   ifThenElse :: repr Bool -> repr a -> repr a -> repr a
 128   ifThenElse = liftDerived3 ifThenElse
 129   default ifThenElse ::
 130     FromDerived3 IfThenElseable repr =>
 131     repr Bool -> repr a -> repr a -> repr a
 132
 133 -- * Class 'Listable'
 134 class Listable repr where
 135   cons :: repr (a -> [a] -> [a])
 136   nil :: repr [a]
 137   cons = liftDerived cons
 138   nil = liftDerived nil
 139   default cons ::
 140     FromDerived Listable repr =>
 141     repr (a -> [a] -> [a])
 142   default nil ::
 143     FromDerived Listable repr =>
 144     repr [a]
 145
 146 -- * Class 'Maybeable'
 147 class Maybeable repr where
 148   nothing :: repr (Maybe a)
 149   just :: repr (a -> Maybe a)
 150   nothing = liftDerived nothing
 151   just = liftDerived just
 152   default nothing ::
 153     FromDerived Maybeable repr =>
 154     repr (Maybe a)
 155   default just ::
 156     FromDerived Maybeable repr =>
 157     repr (a -> Maybe a)
 158
 159 -- * Class 'IsoFunctor'
 160 class IsoFunctor repr where
 161   (<%>) :: Iso a b -> repr a -> repr b
 162   (<%>) iso = liftDerived1 (iso <%>)
 163   default (<%>) ::
 164     FromDerived1 IsoFunctor repr =>
 165     Iso a b -> repr a -> repr b
 166
 167 -- ** Type 'Iso'
 168 data Iso a b = Iso { a2b :: a->b, b2a :: b->a }
 169
 170 -- * Class 'ProductFunctor'
 171 class ProductFunctor repr where
 172   (<.>) :: repr a -> repr b -> repr (a, b)
 173   (<.>) = liftDerived2 (<.>)
 174   default (<.>) ::
 175     FromDerived2 ProductFunctor repr =>
 176     repr a -> repr b -> repr (a, b)
 177
 178 -- * Class 'SumFunctor'
 179 class SumFunctor repr where
 180   (<+>) :: repr a -> repr b -> repr (Either a b)
 181   (<+>) = liftDerived2 (<+>)
 182   default (<+>) ::
 183     FromDerived2 SumFunctor repr =>
 184     repr a -> repr b -> repr (Either a b)
 185
 186 -- * Class 'AlternativeFunctor'
 187 class AlternativeFunctor repr where
 188   (<|>) :: repr a -> repr a -> repr a
 189   (<|>) = liftDerived2 (<|>)
 190   default (<|>) ::
 191     FromDerived2 AlternativeFunctor repr =>
 192     repr a -> repr a -> repr a
 193
 194 -- * Class 'Dicurryable'
 195 class Dicurryable repr where
 196   dicurry ::
 197     CurryN args =>
 198     proxy args ->
 199     (args-..->a) -> -- construction
 200     (a->Tuples args) -> -- destruction
 201     repr (Tuples args) ->
 202     repr a
 203   dicurry args constr destr = liftDerived1 (dicurry args constr destr)
 204   default dicurry ::
 205     FromDerived1 Dicurryable repr =>
 206     CurryN args =>
 207     proxy args ->
 208     (args-..->a) ->
 209     (a->Tuples args) ->
 210     repr (Tuples args) ->
 211     repr a
 212
 213 construct ::
 214   forall args a repr.
 215   Dicurryable repr =>
 216   Generic a =>
 217   EoTOfRep a =>
 218   CurryN args =>
 219   Tuples args ~ EoT (ADT a) =>
 220   (args ~ Args (args-..->a)) =>
 221   (args-..->a) ->
 222   repr (Tuples args) ->
 223   repr a
 224 construct f = dicurry (Proxy::Proxy args) f eotOfadt
 225
 226 adt ::
 227   forall adt repr.
 228   IsoFunctor repr =>
 229   Generic adt =>
 230   RepOfEoT adt =>
 231   EoTOfRep adt =>
 232   repr (EoT (ADT adt)) ->
 233   repr adt
 234 adt = (<%>) (Iso adtOfeot eotOfadt)
 235
 236 -- ** Class 'Emptyable'
 237 class Emptyable repr where
 238   empty :: repr a
 239   empty = liftDerived empty
 240   default empty ::
 241     FromDerived Emptyable repr =>
 242     repr a
 243
 244 -- ** Class 'Optionable'
 245 class Optionable repr where
 246   option :: repr a -> repr a
 247   optional :: repr a -> repr (Maybe a)
 248   option = liftDerived1 option
 249   optional = liftDerived1 optional
 250   default option ::
 251     FromDerived1 Optionable repr =>
 252     repr a -> repr a
 253   default optional ::
 254     FromDerived1 Optionable repr =>
 255     repr a -> repr (Maybe a)
 256
 257 -- * Class 'Repeatable'
 258 class Repeatable repr where
 259   many0 :: repr a -> repr [a]
 260   many1 :: repr a -> repr [a]
 261   many0 = liftDerived1 many0
 262   many1 = liftDerived1 many1
 263   default many0 ::
 264     FromDerived1 Repeatable repr =>
 265     repr a -> repr [a]
 266   default many1 ::
 267     FromDerived1 Repeatable repr =>
 268     repr a -> repr [a]
 269
 270 -- * Class 'Permutable'
 271 class Permutable repr where
 272   -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
 273   type Permutation (repr:: ReprKind) = (r :: ReprKind) | r -> repr
 274   type Permutation repr = Permutation (Derived repr)
 275   permutable :: Permutation repr a -> repr a
 276   perm :: repr a -> Permutation repr a
 277   noPerm :: Permutation repr ()
 278   permWithDefault :: a -> repr a -> Permutation repr a
 279   optionalPerm ::
 280     Eitherable repr => IsoFunctor repr => Permutable repr =>
 281     repr a -> Permutation repr (Maybe a)
 282   optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
 283
 284 (<&>) ::
 285   Permutable repr =>
 286   ProductFunctor (Permutation repr) =>
 287   repr a ->
 288   Permutation repr b ->
 289   Permutation repr (a, b)
 290 x <&> y = perm x <.> y
 291
 292 (<?&>) ::
 293   Eitherable repr =>
 294   IsoFunctor repr =>
 295   Permutable repr =>
 296   ProductFunctor (Permutation repr) =>
 297   repr a ->
 298   Permutation repr b ->
 299   Permutation repr (Maybe a, b)
 300 x <?&> y = optionalPerm x <.> y
 301
 302 (<*&>) ::
 303   Eitherable repr =>
 304   Repeatable repr =>
 305   IsoFunctor repr =>
 306   Permutable repr =>
 307   ProductFunctor (Permutation repr) =>
 308   repr a ->
 309   Permutation repr b ->
 310   Permutation repr ([a],b)
 311 x <*&> y = permWithDefault [] (many1 x) <.> y
 312
 313 (<+&>) ::
 314   Eitherable repr =>
 315   Repeatable repr =>
 316   IsoFunctor repr =>
 317   Permutable repr =>
 318   ProductFunctor (Permutation repr) =>
 319   repr a ->
 320   Permutation repr b ->
 321   Permutation repr ([a],b)
 322 x <+&> y = perm (many1 x) <.> y
 323
 324 infixr 4 <&>
 325 infixr 4 <?&>
 326 infixr 4 <*&>
 327 infixr 4 <+&>
 328
 329 {-# INLINE (<&>)  #-}
 330 {-# INLINE (<?&>) #-}
 331 {-# INLINE (<*&>) #-}
 332 {-# INLINE (<+&>) #-}
 333
 334 -- * Class 'Routable'
 335 class Routable repr where
 336   (<!>) :: repr a -> repr b -> repr (a, b)
 337   (<!>) = liftDerived2 (<!>)
 338   default (<!>) ::
 339     FromDerived2 Routable repr =>
 340     repr a -> repr b -> repr (a,b)
 341
 342 -- | Like @(,)@ but @infixr@.
 343 -- Mostly useful for clarity when using 'Routable'.
 344 pattern (:!:) :: a -> b -> (a,b)
 345 pattern a:!:b <- (a,b)
 346   where a:!:b = (a,b)
 347 infixr 3 :!:
 348
 349 -- * Class 'Voidable'
 350 -- | FIXME: this class should likely be removed
 351 class Voidable repr where
 352   void :: a -> repr a -> repr ()
 353   void = liftDerived1 Fun.. void
 354   default void ::
 355     FromDerived1 Voidable repr =>
 356     a -> repr a -> repr ()
 357
 358 -- * Class 'Substractable'
 359 class Substractable repr where
 360   (<->) :: repr a -> repr b -> repr a
 361   (<->) = liftDerived2 (<->)
 362   default (<->) ::
 363     FromDerived2 Substractable repr =>
 364     repr a -> repr b -> repr a
 365 infixr 3 <->