src/Symantic/Syntaxes/CurryN.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DataKinds #-}
   3 module Symantic.CurryN where
   4
   5 import Data.Function (($), (.))
   6 import Data.Kind (Type)
   7
   8 import Symantic.ADT (Tuples)
   9
  10 -- * Class 'CurryN'
  11 -- | Produce and consume 'Tuples'.
  12 -- Not actually useful for the Generic side of this module,
  13 -- but related through the use of 'Tuples'.
  14 class CurryN args where
  15   -- Like 'curry' but for an arbitrary number of nested 2-tuples.
  16   curryN :: (Tuples args -> res) -> args-..->res
  17   -- Like 'uncurry' but for an arbitrary number of nested 2-tuples.
  18   uncurryN :: (args-..->res) -> Tuples args -> res
  19   -- Like 'fmap' on @('->')@ but for an arbitrary number of arguments.
  20   mapresultN :: (a->b) -> (args-..->a) -> args-..->b
  21 instance CurryN '[a] where
  22   curryN = ($)
  23   uncurryN = ($)
  24   mapresultN = (.)
  25 instance CurryN (b ': as) => CurryN (a ': b ': as) where
  26   curryN f x = curryN @(b ': as) (\xs -> f (x, xs))
  27   uncurryN f (x, xs) = uncurryN @(b ': as) (f x) xs
  28   mapresultN f as2r = mapresultN @(b ': as) f . as2r
  29
  30 -- ** Type family ('-..->')
  31 type family (args :: [Type]) -..-> (r :: Type) :: Type where
  32   '[]        -..-> r = r
  33   (a : args) -..-> r = a -> args -..-> r
  34 -- ** Type family 'Args'
  35 type family Args (f :: Type) :: [Type] where
  36   Args (a -> r) = a : Args r
  37   Args r = '[]
  38 -- ** Type family 'Result'
  39 type family Result (as :: Type) :: Type where
  40   Result (a -> r) = Result r
  41   Result r = r