src/Symantic/Syntaxes/CurryN.hs

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