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 'AlternativeFunctor'
 179 class AlternativeFunctor repr where
 180   (<+>) :: repr a -> repr a -> repr a
 181   (<+>) = liftDerived2 (<+>)
 182   default (<+>) ::
 183     FromDerived2 AlternativeFunctor repr =>
 184     repr a -> repr a -> repr a
 185
 186 -- * Class 'Dicurryable'
 187 class Dicurryable repr where
 188   dicurry ::
 189     CurryN args =>
 190     proxy args ->
 191     (args-..->r) -> -- construction
 192     (r->Tuples args) -> -- destruction
 193     repr (args-..->k) ->
 194     repr (r->k)
 195   dicurry args constr destr = liftDerived1 (dicurry args constr destr)
 196   default dicurry ::
 197     FromDerived1 Dicurryable repr =>
 198     CurryN args =>
 199     proxy args ->
 200     (args-..->r) ->
 201     (r->Tuples args) ->
 202     repr (args-..->k) ->
 203     repr (r->k)
 204
 205 construct ::
 206   forall args a k repr.
 207   Dicurryable repr =>
 208   Generic a =>
 209   EoTOfRep a =>
 210   CurryN args =>
 211   Tuples args ~ EoT (ADT a) =>
 212   (args ~ Args (args-..->a)) =>
 213   (args-..->a) ->
 214   repr (args-..->k) ->
 215   repr (a -> k)
 216 construct f = dicurry (Proxy::Proxy args) f eotOfadt
 217
 218 adt ::
 219   forall adt repr.
 220   IsoFunctor repr =>
 221   Generic adt =>
 222   RepOfEoT adt =>
 223   EoTOfRep adt =>
 224   repr (EoT (ADT adt)) ->
 225   repr adt
 226 adt = (<%>) (Iso adtOfeot eotOfadt)
 227
 228 -- ** Class 'Emptyable'
 229 class Emptyable repr where
 230   empty :: repr a
 231   empty = liftDerived empty
 232   default empty ::
 233     FromDerived Emptyable repr =>
 234     repr a
 235
 236 -- ** Class 'Optionable'
 237 class Optionable repr where
 238   option :: repr a -> repr a
 239   optional :: repr a -> repr (Maybe a)
 240   option = liftDerived1 option
 241   optional = liftDerived1 optional
 242   default option ::
 243     FromDerived1 Optionable repr =>
 244     repr a -> repr a
 245   default optional ::
 246     FromDerived1 Optionable repr =>
 247     repr a -> repr (Maybe a)
 248
 249 -- * Class 'Repeatable'
 250 class Repeatable repr where
 251   many0 :: repr a -> repr [a]
 252   many1 :: repr a -> repr [a]
 253   many0 = liftDerived1 many0
 254   many1 = liftDerived1 many1
 255   default many0 ::
 256     FromDerived1 Repeatable repr =>
 257     repr a -> repr [a]
 258   default many1 ::
 259     FromDerived1 Repeatable repr =>
 260     repr a -> repr [a]
 261
 262 -- * Class 'Permutable'
 263 class Permutable repr where
 264   -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
 265   type Permutation (repr:: ReprKind) = (r :: ReprKind) | r -> repr
 266   type Permutation repr = Permutation (Derived repr)
 267   permutable :: Permutation repr a -> repr a
 268   perm :: repr a -> Permutation repr a
 269   noPerm :: Permutation repr ()
 270   permWithDefault :: a -> repr a -> Permutation repr a
 271   optionalPerm ::
 272     Eitherable repr => IsoFunctor repr => Permutable repr =>
 273     repr a -> Permutation repr (Maybe a)
 274   optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
 275
 276 (<&>) ::
 277   Permutable repr =>
 278   ProductFunctor (Permutation repr) =>
 279   repr a ->
 280   Permutation repr b ->
 281   Permutation repr (a, b)
 282 x <&> y = perm x <.> y
 283
 284 (<?&>) ::
 285   Eitherable repr =>
 286   IsoFunctor repr =>
 287   Permutable repr =>
 288   ProductFunctor (Permutation repr) =>
 289   repr a ->
 290   Permutation repr b ->
 291   Permutation repr (Maybe a, b)
 292 x <?&> y = optionalPerm x <.> y
 293
 294 (<*&>) ::
 295   Eitherable repr =>
 296   Repeatable repr =>
 297   IsoFunctor repr =>
 298   Permutable repr =>
 299   ProductFunctor (Permutation repr) =>
 300   repr a ->
 301   Permutation repr b ->
 302   Permutation repr ([a],b)
 303 x <*&> y = permWithDefault [] (many1 x) <.> y
 304
 305 (<+&>) ::
 306   Eitherable repr =>
 307   Repeatable repr =>
 308   IsoFunctor repr =>
 309   Permutable repr =>
 310   ProductFunctor (Permutation repr) =>
 311   repr a ->
 312   Permutation repr b ->
 313   Permutation repr ([a],b)
 314 x <+&> y = perm (many1 x) <.> y
 315
 316 infixr 4 <&>
 317 infixr 4 <?&>
 318 infixr 4 <*&>
 319 infixr 4 <+&>
 320
 321 {-# INLINE (<&>)  #-}
 322 {-# INLINE (<?&>) #-}
 323 {-# INLINE (<*&>) #-}
 324 {-# INLINE (<+&>) #-}
 325
 326 -- * Class 'Routable'
 327 class Routable repr where
 328   (<!>) :: repr a -> repr b -> repr (a, b)
 329   (<!>) = liftDerived2 (<!>)
 330   default (<!>) ::
 331     FromDerived2 Routable repr =>
 332     repr a -> repr b -> repr (a,b)
 333
 334 -- | Like @(,)@ but @infixr@.
 335 -- Mostly useful for clarity when using 'Routable'.
 336 pattern (:!:) :: a -> b -> (a,b)
 337 pattern a:!:b <- (a,b)
 338   where a:!:b = (a,b)
 339 infixr 3 :!:
 340
 341 -- * Class 'Voidable'
 342 -- | FIXME: this class should likely be removed
 343 class Voidable repr where
 344   void :: a -> repr a -> repr ()
 345   void = liftDerived1 Fun.. void
 346   default void ::
 347     FromDerived1 Voidable repr =>
 348     a -> repr a -> repr ()
 349
 350 -- * Class 'Substractable'
 351 class Substractable repr where
 352   (<->) :: repr a -> repr b -> repr a
 353   (<->) = liftDerived2 (<->)
 354   default (<->) ::
 355     FromDerived2 Substractable repr =>
 356     repr a -> repr b -> repr a
 357 infixr 3 <->