src/Symantic/Syntaxes/CurryN.hs

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