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