src/Symantic/CurryN.hs

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