From df2c84e1ddf7e9dbe6e4c0ddd6831266655ece33 Mon Sep 17 00:00:00 2001
From: Frederick Pringle <freddyjepringle@gmail.com>
Date: Sat, 8 Mar 2025 12:19:45 +0100
Subject: [PATCH 1/2] Way simpler

---
 src/Generics/Case.hs  | 266 +++++++++---------------------------------
 src/Generics/Chain.hs | 260 ++++++++++++++---------------------------
 2 files changed, 141 insertions(+), 385 deletions(-)

diff --git a/src/Generics/Case.hs b/src/Generics/Case.hs
index 842b57e..be7d18e 100644
--- a/src/Generics/Case.hs
+++ b/src/Generics/Case.hs
@@ -9,7 +9,7 @@ and error-prone at worst. This module gives us these functions for any type whic
 implements 'Generic'.
 
 For any single-constructor types, such as tuples, this gives us generic uncurrying without
-any extra effort - see 'tupleR', 'tuple3R'.
+any extra effort - see 'tupleL', 'tuple3L'.
 
 == Example
 
@@ -33,15 +33,16 @@ instance Generic (These a b)      -- we could also do this using DeriveAnyClass
 
 We're going to re-implement the case analysis function
 [these](https://hackage.haskell.org/package/these-1.2.1/docs/Data-These.html#v:these),
-using 'gcaseR'. Our type has 3 constructors, so our function will have 4 arguments:
-one function for each constructor, and one for the @These@ we're analysing.
+using 'gcase'. Our type has 3 constructors, so our function will have 4 arguments:
+one for the @These@ we're analysing, and one function for each constructor.
 The function is polymorphic in the result type.
 
 @
 these ::
   forall a b c.
+  These a b ->
   _ -> _ -> _ ->
-  These a b -> c
+  c
 @
 
 What are the types of those 3 functions? For each constructor, we make a function type taking
@@ -50,63 +51,59 @@ one of each of the argument types, and returning our polymorphic result type @c@
 @
 these ::
   forall a b c.
+  These a b ->
   (a -> c) ->       -- for This
   (b -> c) ->       -- for That
   (a -> b -> c) ->  -- for These
-  These a b -> c
+  c
 @
 
-Finally, we add the implementation, which is just 'gcaseR':
+Finally, we add the implementation, which is just 'gcase':
 
 @
 these ::
   forall a b c.
+  These a b ->
   (a -> c) ->
   (b -> c) ->
   (a -> b -> c) ->
-  These a b -> c
-these = gcaseR @(These a b)
+  c
+these = gcase
 @
 
-Note that we need the @TypeApplications@ extension here. If you're really against this extension,
-see 'gcaseR_'.
+Note that we could have written the entire thing more succintly using 'Analysis':
 
-For a version that takes the datatype before the functions, see 'gcaseL'.
+@
+these ::
+  forall a b c.
+  Analysis (These a b) c
+these = gcase
+@
 -}
 module Generics.Case
   ( -- * Generic case analysis
-    AnalysisR
-  , gcaseR
-  , gcaseR_
-  , AnalysisL
-  , gcaseL
+    Analysis
+  , gcase
 
     -- * Examples
 
     -- ** Maybe
-  , maybeR
   , maybeL
 
     -- ** Either
-  , eitherR
   , eitherL
 
     -- ** Bool
-  , boolR
   , boolL
 
     -- ** Tuples
-  , tupleR
   , tupleL
-  , tuple3R
   , tuple3L
 
     -- ** Lists
-  , listR
   , listL
 
     -- ** Non-empty lists
-  , nonEmptyR
   , nonEmptyL
   )
 where
@@ -115,284 +112,129 @@ import Data.List.NonEmpty (NonEmpty)
 import Generics.Chain
 import Generics.SOP
 
-{- | The type of an analysis function on a generic type, in which the type comes after the functions.
+{- | The type of an analysis function on a generic type, in which the type comes before the functions.
 
-You shouldn't ever need to create a function of this type; use 'gcaseR' or 'gcaseR_'.
+You shouldn't ever need to create a function of this type manually; use 'gcase'.
 
 You can exapand the type in a repl:
 
 @
-ghci> :k! AnalysisR (Maybe a) r
-AnalysisR (Maybe a) r :: *
-= r -> (a -> r) -> Maybe a -> r
-@
--}
-type AnalysisR a r = ChainsR (Code a) a r
-
-{- | Same as 'AnalysisR', but the type being anlaysed comes before the functions.
-
-You shouldn't ever need to create a function of this type; use 'gcaseL'.
-
-@
-ghci> :k! AnalysisL (Maybe a) r
-AnalysisL (Maybe a) r :: *
+ghci> :k! Analysis (Maybe a) r
+Analysis (Maybe a) r :: *
 = Maybe a -> r -> (a -> r) -> r
 @
 -}
-type AnalysisL a r = a -> ChainsL (Code a) r
+type Analysis a r = a -> Chains (Code a) r
 
-{- | Generic case analysis, with the same shape as 'maybe' or 'either' (functions before dataype).
+{- | Generic case analysis. Similar to 'maybe' or 'either', except the type being analysed comes
+before the functions, instead of after.
 
 See the module header for a detailed explanation.
 -}
-gcaseR ::
-  forall a r.
-  (Generic a) =>
-  AnalysisR a r
-gcaseR = toChains @(Code a) @(a -> r) f
-  where
-    f c a = applyNSChain c (from a)
-
-{- | Morally the same as 'gcaseR', but takes a 'Proxy' to avoid @TypeApplications@.
-
-Following our @These@ example:
-
-@
-these_ ::
-  forall a b c.
-  (a -> c) ->
-  (b -> c) ->
-  (a -> b -> c) ->
-  These a b -> c
-these_ = gcaseR_ (Proxy :: Proxy (These a b))
-@
--}
-gcaseR_ ::
+gcase ::
   forall a r.
   (Generic a) =>
-  Proxy a ->
-  AnalysisR a r
-gcaseR_ _ = gcaseR @a @r
-
-{- | Simliar to 'gcaseR', except the type being analysed comes before the functions, instead of
-after.
-
-Unlike @gcaseR@, this shouldn't need @TypeApplications@.
-
-Following our @These@ example:
-
-@
-theseL ::
-  forall a b c.
-  These a b ->
-  (a -> c) ->
-  (b -> c) ->
-  (a -> b -> c) ->
-  c
-theseL = gcaseL
-@
--}
-gcaseL ::
-  forall a r.
-  (Generic a) =>
-  AnalysisL a r
-gcaseL a = toChains @(Code a) @r f
-  where
-    f c = applyNSChain c (from a)
+  Analysis a r
+gcase = applyChains @(Code a) @r . unSOP . from
 
 ------------------------------------------------------------
 -- Examples
 
-{- | 'maybe', implemented using 'gcaseR_'.
-
-Equivalent type signature:
-
-@
-maybeR :: forall a r. 'AnalysisR' (Maybe a) r
-@
-
-The implementation is just:
-
-@
-maybeR = gcaseR_ (Proxy :: Proxy (Maybe a))
-@
--}
-maybeR :: forall a r. r -> (a -> r) -> Maybe a -> r
-maybeR = gcaseR_ (Proxy :: Proxy (Maybe a))
-
-{- | Same as 'maybeR', except the 'Maybe' comes before the case functions.
+{- | Same as 'maybe', except the 'Maybe' comes before the case functions.
 
 Equivalent type signature:
 
 @
-maybeL :: forall a r. AnalysisL (Maybe a) r
+maybeL :: forall a r. Analysis (Maybe a) r
 @
 
 The implementation is just:
 
 @
-maybeL = gcaseL @(Maybe a)
+maybeL = gcase @(Maybe a)
 @
 -}
 maybeL :: forall a r. Maybe a -> r -> (a -> r) -> r
-maybeL = gcaseL
+maybeL = gcase
 
-{- | 'either', implemented using 'gcaseR'.
+{- | Same as 'either', except the 'Either' comes before the case functions.
 
 Equivalent type signature:
 
 @
-eitherR :: forall a b r. 'AnalysisR' (Either a b) r
+eitherL :: forall a b r. 'Analysis' (Either a b) r
 @
 
 The implementation is just:
 
 @
-eitherR = gcaseR @(Either a b)
-@
--}
-eitherR :: forall a b r. (a -> r) -> (b -> r) -> Either a b -> r
-eitherR = gcaseR @(Either a b)
-
-{- | Same as 'eitherR', except the 'Either' comes before the case functions.
-
-Equivalent type signature:
-
-@
-eitherL :: forall a b r. 'AnalysisL' (Either a b) r
-@
-
-The implementation is just:
-
-@
-eitherL = gcaseL
+eitherL = gcase
 @
 -}
 eitherL :: forall a b r. Either a b -> (a -> r) -> (b -> r) -> r
-eitherL = gcaseL
+eitherL = gcase
 
-{- | 'Data.Bool.bool', implemented using 'gcaseR'.
+{- | Same as 'Data.Bool.bool', except the 'Bool' comes before the case functions.
 
 Equivalent type signature:
 
 @
-boolR :: forall r. 'AnalysisR' Bool r
+boolL :: forall r. 'Analysis' Bool r
 @
 
 The implementation is just:
 
 @
-boolR = gcaseR @Bool
-@
--}
-boolR :: forall r. r -> r -> Bool -> r
-boolR = gcaseR @Bool
-
-{- | Same as 'boolR', except the 'Bool' comes before the case functions.
-
-Equivalent type signature:
-
-@
-boolL :: forall r. 'AnalysisL' Bool r
-@
-
-The implementation is just:
-
-@
-boolL = gcaseL
+boolL = gcase
 @
 -}
 boolL :: forall r. Bool -> r -> r -> r
-boolL = gcaseL
+boolL = gcase
 
 {- | Case analysis on a list. Same as
 [list](https://hackage.haskell.org/package/extra/docs/Data-List-Extra.html#v:list)
-from @extra@.
-
-Equivalent type signature:
-
-@
-listR :: forall a r. 'AnalysisR' [a] r
-@
--}
-listR :: forall a r. r -> (a -> [a] -> r) -> [a] -> r
-listR = gcaseR @[a]
-
-{- | Same as 'listR', except the list comes before the case functions.
+from @extra@, except the list comes before the case functions.
 
 Equivalent type signature:
 
 @
-listL :: forall a r. 'AnalysisL' [a] r
+listL :: forall a r. 'Analysis' [a] r
 @
 -}
 listL :: forall a r. [a] -> r -> (a -> [a] -> r) -> r
-listL = gcaseL
+listL = gcase
 
-{- | Case analysis on a tuple. Interestingly, this is the same as 'uncurry'.
+{- | Case analysis on a tuple. Same as 'uncurry', except the tuple comes before the case function.
 
 Equivalent type signature:
 
 @
-tupleR :: forall a b r. 'AnalysisR' (a, b) r
+tupleL :: forall a b r. 'Analysis' (a, b) r
 @
 -}
-tupleR :: forall a b r. (a -> b -> r) -> (a, b) -> r
-tupleR = gcaseR @(a, b)
+tupleL :: forall a b r. (a, b) -> (a -> b -> r) -> r
+tupleL = gcase
 
 {- | Case analysis on a 3-tuple. Same as
 [uncurry3](https://hackage.haskell.org/package/extra/docs/Data-Tuple-Extra.html#v:uncurry3)
-from @extra@.
-
-Equivalent type signature:
-
-@
-tuple3R :: forall a b c r. 'AnalysisR' (a, b, c) r
-@
--}
-tuple3R :: forall a b c r. (a -> b -> c -> r) -> (a, b, c) -> r
-tuple3R = gcaseR @(a, b, c)
-
-{- | Same as 'tupleR', except the tuple comes before the case function.
+from @extra@, except the tuple comes before the case function.
 
 Equivalent type signature:
 
 @
-tupleL :: forall a b r. 'AnalysisL' (a, b) r
-@
--}
-tupleL :: forall a b r. (a, b) -> (a -> b -> r) -> r
-tupleL = gcaseL
-
-{- | Same as 'tuple3R', except the tuple comes before the case function.
-
-Equivalent type signature:
-
-@
-tupleL :: forall a b c r. 'AnalysisL' (a, b, c) r
+tupleL :: forall a b c r. 'Analysis' (a, b, c) r
 @
 -}
 tuple3L :: forall a b c r. (a, b, c) -> (a -> b -> c -> r) -> r
-tuple3L = gcaseL
+tuple3L = gcase
 
 {- | Case analysis on a non-empty list.
 
 Equivalent type signature:
 
 @
-nonEmptyR :: forall a r. 'AnalysisR' (NonEmpty a) r
-@
--}
-nonEmptyR :: forall a r. (a -> [a] -> r) -> NonEmpty a -> r
-nonEmptyR = gcaseR @(NonEmpty a)
-
-{- | Same as 'nonEmptyR', except the non-empty list comes before the case function.
-
-Equivalent type signature:
-
-@
-nonEmptyL :: forall a r. 'AnalysisL' (NonEmpty a) r
+nonEmptyL :: forall a r. 'Analysis' (NonEmpty a) r
 @
 -}
 nonEmptyL :: forall a r. NonEmpty a -> (a -> [a] -> r) -> r
-nonEmptyL = gcaseL
+nonEmptyL = gcase
diff --git a/src/Generics/Chain.hs b/src/Generics/Chain.hs
index 1ec033f..231cf77 100644
--- a/src/Generics/Chain.hs
+++ b/src/Generics/Chain.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE EmptyCase #-}
+
 {- | Uniform representation + handling of n-ary functions.
 
 This module gives us types and functions (both value- and type-level) to work
@@ -43,91 +45,50 @@ The 'Chain' family does exactly that. Since GHC can unify these types, we
 can use 'Chain' in our types signatures in "Generics.Case" and the user doesn't
 have to think about SOP, generics etc.
 
-However, it's hard to manipulate a 'Chain' in a generic way. We want a principled
-way to manipulate any function type, regardless of how many arguments it has.
-That's where [sop-core](https://hackage.haskell.org/package/sop-core) comes in.
-
-The second way to unify all function types is using uncurrying: rather than a series of
-function arrows, we see a function as mapping a tuple (or a heterogeneous list) to a result type:
-
-@
-f1_tuple :: (Int) -> Int
-f2_tuple :: (a, (b, a)) -> c
-f3_tuple :: (a, a -> a, a -> a -> a) -> a
-@
-
-Or, in SOP terminology:
-
-@
-f1_NP_ :: NP '[Int] -> Int
-f2_NP_ :: NP '[a, (b, a)] -> c
-f3_NP_ :: NP '[a, a -> a, a -> a -> a] -> a
-@
-
-Since these types are equivalent, once we convert to the 'NP' representation we can then manipulate
-them using all the usual SOP machinery, and then convert back.
-The 'ChainF' type does exactly that, and the 'toChain' and 'fromChain' functions allow us to
-convert between the two representations on the value level:
-
 @
-f1_NP :: ChainF Int '[Int]
-f1_NP = fromChain f1
-f2_NP :: ChainF c '[a, (b, a)]
-f2_NP = fromChain f2
-f3_NP :: ChainF a '[a, a -> a, a -> a -> a]
-f3_NP = fromChain f3
+f1__ :: Chain '[Int] Int
+f1__ = f1_
+f2__ :: Chain '[a, (b, a)] c
+f2__ = f2_
+f3__ :: Chain '[a, a -> a, a -> a -> a] a
+f3__ = f3_
 @
 
-Note that the argument list now comes after the result type: this is so that we can use 'ChainF'
-with 'NP' etc.
-
-Unlike 'Chain', 'ChainF' is a concrete type using SOP stuff. Ideally we don't want to expose
-it to the user and force them to supply functions that take 'NP's as arguments.
-
-'Chains' and @'NP' ('ChainF' r)@ iterate on these concepts: 'Chains' is a type-level family represent
-a function of functions, and @'NP' ('ChainF' r)@ is the SOP equivalent. We can convert between them
-using 'toChains' and 'fromChains'. This lets us represent "case analysis" functions like
+'Chains' iterates on this concepts: it is a type-level family representing
+a function of functions. This lets us represent "case analysis" functions like
 'maybe' and 'either' nicely (see "Generics.Case"):
 
 @
-maybe' :: forall a r. 'ChainsR' '[ '[], '[a]] (Maybe a) r
-maybe' = 'maybe'
+maybe' :: forall a r. Maybe a -> 'Chains' '[ '[], '[a]] r
+maybe' m r f = 'maybe' r f m
 
-either' :: forall a b r. 'ChainsR' '[ '[a], '[b]] (Either a b) r
-either' = 'either'
-@
+either' :: forall a b r. Either a b -> 'Chains' '[ '[a], '[b]] r
+either' e fa fb = 'either' fa fb e
 
-'ChainsL' and 'ChainsR' are just variants of 'Chains' that allow us to decide whether the
-type we're analysing comes before or after the analysis functions.
+bool' :: forall r. Bool -> 'Chains' '[ '[], '[]] r
+bool' b f t = 'Data.Bool.bool' f t b
+@
 -}
 module Generics.Chain
-  ( -- * Type functions
+  ( -- * Representation of n-ary functions
     Chain
   , toChain
   , fromChain
+
+    -- * Functions of functions
   , Chains
-  , toChains
-  , fromChains
-  , ChainsL
-  , toChainsL
-  , fromChainsL
-  , ChainsR
-  , toChainsR
-  , fromChainsR
-
-    -- * Concrete SOP types
-  , ChainF (..)
-  , applyChain
-  , applyNSChain
-  , chainFn
+  , applyChains
+  , constChain
   )
 where
 
 import Data.SOP
-import Data.SOP.NP
-import Data.SOP.NS
 
-{- | Isomorphic to @ChainF r xs@, as witnessed by 'fromChain' and 'toChain'
+{- | Type family representing an n-ary function. The first argument is a type-level list
+that represent the arguments to the function; the second argument represents the result of
+the function.
+
+Isomorphic to @'NP' 'I' xs -> r@, as witnessed by 'fromChain' and 'toChain'.
 
 @
 Chain '[x, y, z] r
@@ -138,143 +99,96 @@ type family Chain xs r where
   Chain '[] r = r
   Chain (x ': xs) r = x -> Chain xs r
 
-{- | Convert from type family 'Chain' to concrete type 'ChainF'.
+{- | Convert from type family 'Chain' to a function of a product 'NP'.
 
 Inverse of 'toChain'.
 -}
-fromChain :: forall xs r. (SListI xs) => Chain xs r -> ChainF r xs
-fromChain sc = case sList @xs of
-  SNil -> ChainF (const sc)
-  SCons ->
-    ChainF $ \(I x :* xs) ->
-      let ChainF f = fromChain $ sc x
-      in  f xs
+fromChain :: forall xs r. Chain xs r -> NP I xs -> r
+fromChain c = \case
+  Nil -> c
+  I x :* xs -> fromChain (c x) xs
 
-{- | Convert from concrete type 'ChainF' to type family 'Chain'.
+{- | Convert from a function of a product, to type family 'Chain'.
 
 e.g.
 
 @
-chainF :: ChainF String '[Int, Maybe Char]
-chainF = ChainF $ \(I n :* I mChar :* Nil) -> show n <> " " <> show mChar
+productChain :: 'NP' 'I' '[Int, Maybe Char] -> String
+productChain ('I' n :* 'I' mChar :* Nil) = show n <> " " <> show mChar
 
-singleChain :: Int -> Maybe Char -> String
-singleChain = toChain chainF
+chain :: Int -> Maybe Char -> String
+chain = toChain productChain
 @
 -}
-toChain :: forall xs r. (SListI xs) => ChainF r xs -> Chain xs r
-toChain (ChainF f) = case sList @xs of
+toChain :: forall xs r. (SListI xs) => (NP I xs -> r) -> Chain xs r
+toChain f = case sList @xs of
   SNil -> f Nil
-  SCons -> \x -> toChain $ ChainF $ \xs -> f (I x :* xs)
+  SCons -> \x -> toChain $ \xs -> f (I x :* xs)
 
-{- | Isomorphic to @NP (ChainF final) xss -> ret@, as witnessed by 'toChains' and 'fromChains'.
+{- | The next level up from 'Chain': now we represent a function of functions.
 
 @
-Chains '[ '[x,y], '[z], '[]] ret final
-  ~ Chain '[x,y] final -> Chain '[z] final -> Chain '[] final -> ret
-  ~ (x -> y -> final)  -> (z -> final)     -> final           -> ret
+Chains '[ '[x,y], '[z], '[]] r
+  ~ Chain '[x,y] r -> Chain '[z] r -> Chain '[] r -> r
+  ~ (x -> y -> r)  -> (z -> r)     -> r           -> r
 @
--}
-type family Chains xss ret final where
-  Chains '[] ret final = ret
-  Chains (xs ': xss) ret final = Chain xs final -> Chains xss ret final
 
-{- | Convert from a function of a product of concrete types 'ChainF' to type family 'Chains'.
-
-e.g.
+In an ideal world, we'd be able to write:
 
 @
-maybeF :: NP (ChainF Int) '[ '[], '[Char]] -> Maybe Char -> Int
-maybeF (ChainF n :* _) Nothing = n Nil
-maybeF (_ :* ChainF f :* Nil) (Just c) = f (I c :* Nil)
-
-maybeR :: Int -> (Char -> Int) -> Maybe Char -> Int
-maybeR = toChains maybeF
-
-maybeL :: Maybe Char -> Int -> (Char -> Int) -> Int
-maybeL mc = toChains (flip maybeF mc)
+type Chains xss r = Chain (Map (\xs -> Chain xs r) xss) r
 @
 -}
-toChains ::
-  forall xss ret final.
-  (All SListI xss) =>
-  (NP (ChainF final) xss -> ret) ->
-  Chains xss ret final
-toChains f = case sList @xss of
-  SNil -> f Nil
-  SCons -> \sc -> toChains $ \xs -> f (fromChain sc :* xs)
+type family Chains xss r where
+  Chains '[] r = r
+  Chains (xs ': xss) r = Chain xs r -> Chains xss r
 
-{- | Convert from type family 'Chains' to a function of a product of concrete types 'ChainF'.
+{- | Apply a series of chains. Used to implement 'Generics.Case.gcase'.
 
-Inverse of 'toChains'.
--}
-fromChains ::
-  forall xss ret final.
-  (All SListI xss) =>
-  Chains xss ret final ->
-  NP (ChainF final) xss ->
-  ret
-fromChains r = \case
-  Nil -> r
-  sc :* cs -> fromChains (r $ toChain sc) cs
-
-{- | Isomorphic to @NP (ChainF r) xss -> a -> r@, as witnessed by 'toChainsR' and 'fromChainsR'.
+You can think of the signature and implementation of this function as being:
 
 @
-ChainsR '[ '[x,y], '[z], '[]] a r
-  ~ Chain '[x,y] r -> Chain '[z] r -> Chain '[] r -> a -> r
-  ~ (x -> y -> r)  -> (z -> r)     -> r           -> a -> r
+applyChains ::
+  'NS' ('NP' 'I') '[xs1, xs2, ... , xsn] ->
+  Chains xs1 r ->
+  Chains xs2 r ->
+  ... ->
+  Chains xsn r ->
+  r
+applyChains (Z x1)                 f1 _  _ ... _  = fromChain f1 xs
+applyChains (S (S x2)              _  f2 _ ... _  = fromChain f2 xs
+...
+applyChains (S (S (... (S xn)..))) _  _  _ ... fn = fromChain fn xs
 @
 -}
-type ChainsR xss a r = Chains xss (a -> r) r
-
--- | Specialisation of 'toChains' to 'ChainsR'.
-toChainsR :: forall xss a r. (All SListI xss) => (NP (ChainF r) xss -> a -> r) -> ChainsR xss a r
-toChainsR = toChains
+applyChains :: forall xss r. (SListI xss) => NS (NP I) xss -> Chains xss r
+applyChains = go shape
+  where
+    go :: forall yss. Shape yss -> NS (NP I) yss -> Chains yss r
+    go = \case
+      ShapeNil -> \case {}
+      ShapeCons (shp :: Shape xs) -> \case
+        Z (npx :: NP I x) -> \cx -> constChain @_ @r (fromChain @x @r cx npx) shp
+        S (s :: NS (NP I) xs) -> \_ -> go shp s
 
--- | Specialisation of 'fromChains' to 'ChainsR'.
-fromChainsR :: forall xss a r. (All SListI xss) => ChainsR xss a r -> (NP (ChainF r) xss -> a -> r)
-fromChainsR = fromChains
+{- | Once we've hit the 'Z' and applied the correspond 'Chain', we've got our final answer and
+we want to skip the rest of the functions and just return. This lets us do that.
 
-{- | Isomorphic to @NP (ChainF r) xss -> r@, as witnessed by 'toChainsL' and 'fromChainsL'.
+You can think of the signature and implementation of this function (ignoring the 'Shape',
+which just helps GHC understand the recursion) as being:
 
 @
-ChainsL '[ '[x,y], '[z], '[]] r
-  ~ Chain '[x,y] r -> Chain '[z] r -> Chain '[] r -> r
-  ~ (x -> y -> r)  -> (z -> r)     -> r           -> r
+applyChains ::
+  r ->
+  Chains xs1 r ->
+  Chains xs2 r ->
+  ... ->
+  Chains xsn r ->
+  r
+applyChains r _ _ ... _ = r
 @
 -}
-type ChainsL xss r = Chains xss r r
-
--- | Specialisation of 'toChains' to 'ChainsL'.
-toChainsL :: forall xss r. (All SListI xss) => (NP (ChainF r) xss -> r) -> ChainsL xss r
-toChainsL = toChains
-
--- | Specialisation of 'fromChains' to 'ChainsL'.
-fromChainsL :: forall xss r. (All SListI xss) => ChainsL xss r -> (NP (ChainF r) xss -> r)
-fromChainsL = fromChains
-
-{- | A concrete type that is equivalent to an n-ary function.
-
-@ChainF r '[x, y, z]@ is isomorphic to @'Chain' '[x, y, z] r@, which simplifies to
-@x -> y -> z -> r@. This isomorphism is witnessed by 'toChain' and 'fromChain'
--}
-newtype ChainF r xs = ChainF (NP I xs -> r)
-
--- | Unwrap a 'ChainF'.
-applyChain :: ChainF r xs -> NP I xs -> r
-applyChain (ChainF f) = f
-{-# INLINE applyChain #-}
-
-{- | Convert a 'ChainF' to a '-.->' function which maps a product of @xs@ to a single value @r@
-(more accurately @'K' r@).
--}
-chainFn :: ChainF r xs -> (NP I -.-> K r) xs
-chainFn = fn . (K .) . applyChain
-{-# INLINE chainFn #-}
-
--- | Apply a product of 'ChainF's to a __sum__ of 'NP's.
-applyNSChain :: forall r xss. (SListI xss) => NP (ChainF r) xss -> SOP I xss -> r
-applyNSChain chains (SOP ns) = collapse_NS $ ap_NS fns ns
-  where
-    fns = liftA_NP chainFn chains
+constChain :: forall xss r. r -> Shape xss -> Chains xss r
+constChain r = \case
+  ShapeNil -> r
+  ShapeCons s -> \_ -> constChain @_ @r r s

From 2b51c6cd1f3af3cf38e6263b263f13e582d4e033 Mon Sep 17 00:00:00 2001
From: Frederick Pringle <freddyjepringle@gmail.com>
Date: Sat, 8 Mar 2025 12:23:13 +0100
Subject: [PATCH 2/2] Update tests

---
 test/Generics/Case/BoolSpec.hs                | 30 +++++++++---------
 test/Generics/Case/Custom/NoParamTypeSpec.hs  | 30 ++++++------------
 test/Generics/Case/Custom/OneParamTypeSpec.hs | 31 +++++++------------
 test/Generics/Case/EitherSpec.hs              | 27 +++++++---------
 test/Generics/Case/MaybeSpec.hs               | 27 +++++++---------
 test/Util.hs                                  | 24 +++++++-------
 6 files changed, 73 insertions(+), 96 deletions(-)

diff --git a/test/Generics/Case/BoolSpec.hs b/test/Generics/Case/BoolSpec.hs
index 39f3150..837a643 100644
--- a/test/Generics/Case/BoolSpec.hs
+++ b/test/Generics/Case/BoolSpec.hs
@@ -6,28 +6,28 @@ import qualified Test.Hspec as H
 import qualified Test.QuickCheck as Q
 import Util
 
+type BoolFn r = Bool -> r -> r -> r
+
+type FunArgs r = '[Bool, r, r]
+
+manual :: BoolFn r
+manual b f t = bool f t b
+
 specBool ::
-  forall a.
-  (Show a, Eq a, Q.Arbitrary a) =>
+  forall r.
+  (Show r, Eq r, Q.Arbitrary r) =>
   String ->
-  (a -> a -> Bool -> a) ->
+  BoolFn r ->
   H.Spec
-specBool name f = specG @'[a, a, Bool] ("bool", bool) (name, f)
-
-boolL_ :: a -> a -> Bool -> a
-boolL_ x y b = boolL b x y
+specBool name f = specG @(FunArgs r) ("bool", manual) (name, f)
 
 spec :: H.Spec
 spec = do
   H.describe "()" $ do
-    specBool @() "boolR" boolR
-    specBool @() "boolL" boolL_
+    specBool @() "boolL" boolL
   H.describe "Char" $ do
-    specBool @Char "boolR" boolR
-    specBool @Char "boolL" boolL_
+    specBool @Char "boolL" boolL
   H.describe "String" $ do
-    specBool @String "boolR" boolR
-    specBool @String "boolL" boolL_
+    specBool @String "boolL" boolL
   H.describe "[Maybe (Int, String)]" $ do
-    specBool @[Maybe (Int, String)] "boolR" boolR
-    specBool @[Maybe (Int, String)] "boolL" boolL_
+    specBool @[Maybe (Int, String)] "boolL" boolL
diff --git a/test/Generics/Case/Custom/NoParamTypeSpec.hs b/test/Generics/Case/Custom/NoParamTypeSpec.hs
index 43ac36b..696e751 100644
--- a/test/Generics/Case/Custom/NoParamTypeSpec.hs
+++ b/test/Generics/Case/Custom/NoParamTypeSpec.hs
@@ -28,23 +28,20 @@ instance Q.Arbitrary NoParamType where
       ]
   shrink = Q.genericShrink
 
-type NPTFn r = r -> (Int -> r) -> (String -> Char -> r) -> NoParamType -> r
+type NPTFn r = NoParamType -> r -> (Int -> r) -> (String -> Char -> r) -> r
 
-type FunArgs r = '[r, Fun Int r, Fun String (Fun Char r), NoParamType]
+type FunArgs r = '[NoParamType, r, Fun Int r, Fun String (Fun Char r)]
 
 type NPTFun r = Chain (FunArgs r) r
 
 manual :: NPTFn r
-manual r fromInt fromStringChar = \case
+manual npt r fromInt fromStringChar = case npt of
   NPT1 -> r
   NPT2 int -> fromInt int
   NPT3 string char -> fromStringChar string char
 
-nptR :: NPTFn r
-nptR = gcaseR @NoParamType
-
-nptL :: NoParamType -> r -> (Int -> r) -> (String -> Char -> r) -> r
-nptL = gcaseL @NoParamType
+nptL :: NPTFn r
+nptL = gcase @NoParamType
 
 specNPT ::
   forall r.
@@ -63,22 +60,15 @@ specNPT name f =
 mkFn ::
   NPTFn r ->
   NPTFun r
-mkFn f r f1 f2 = f r (applyFun f1) (applyFun <$> applyFun f2)
-
-nptL_ :: NPTFn r
-nptL_ r fromInt fromStringChar npt = nptL npt r fromInt fromStringChar
+mkFn f npt' r f1 f2 = f npt' r (applyFun f1) (applyFun <$> applyFun f2)
 
 spec :: H.Spec
 spec = do
   H.describe "()" $ do
-    specNPT @() "nptR" nptR
-    specNPT @() "nptL" nptL_
+    specNPT @() "nptL" nptL
   H.describe "Char" $ do
-    specNPT @Char "nptR" nptR
-    specNPT @Char "nptL" nptL_
+    specNPT @Char "nptL" nptL
   H.describe "String" $ do
-    specNPT @String "nptR" nptR
-    specNPT @String "nptL" nptL_
+    specNPT @String "nptL" nptL
   H.describe "[Maybe (Int, String)]" $ do
-    specNPT @[Maybe (Int, String)] "nptR" nptR
-    specNPT @[Maybe (Int, String)] "nptL" nptL_
+    specNPT @[Maybe (Int, String)] "nptL" nptL
diff --git a/test/Generics/Case/Custom/OneParamTypeSpec.hs b/test/Generics/Case/Custom/OneParamTypeSpec.hs
index 1ea2135..0993271 100644
--- a/test/Generics/Case/Custom/OneParamTypeSpec.hs
+++ b/test/Generics/Case/Custom/OneParamTypeSpec.hs
@@ -28,23 +28,20 @@ instance (Q.Arbitrary a) => Q.Arbitrary (OneParamType a) where
       ]
   shrink = Q.genericShrink
 
-type OPTFn a r = (a -> r) -> (Maybe a -> r) -> (a -> a -> r) -> OneParamType a -> r
+type OPTFn a r = OneParamType a -> (a -> r) -> (Maybe a -> r) -> (a -> a -> r) -> r
 
-type FunArgs a r = '[Fun a r, Fun (Maybe a) r, Fun a (Fun a r), OneParamType a]
+type FunArgs a r = '[OneParamType a, Fun a r, Fun (Maybe a) r, Fun a (Fun a r)]
 
 type OPTFun a r = Chain (FunArgs a r) r
 
 manual :: OPTFn a r
-manual fromA fromM fromAs = \case
+manual opt fromA fromM fromAs = case opt of
   OPT1 a -> fromA a
   OPT2 m -> fromM m
   OPT3 a1 a2 -> fromAs a1 a2
 
-optR :: forall a r. OPTFn a r
-optR = gcaseR @(OneParamType a)
-
-optL :: forall a r. OneParamType a -> (a -> r) -> (Maybe a -> r) -> (a -> a -> r) -> r
-optL = gcaseL @(OneParamType a)
+gopt :: forall a r. OPTFn a r
+gopt = gcase @(OneParamType a)
 
 specOPT ::
   forall a r.
@@ -65,24 +62,18 @@ specOPT name f =
     (name, mkFn f)
 
 mkFn ::
+  forall a r.
   OPTFn a r ->
   OPTFun a r
-mkFn f f1 f2 f3 = f (applyFun f1) (applyFun f2) (applyFun <$> applyFun f3)
-
-optL_ :: OPTFn a r
-optL_ r fromInt fromStringChar opt = optL opt r fromInt fromStringChar
+mkFn f m f1 f2 f3 = f m (applyFun f1) (applyFun f2) (applyFun <$> applyFun f3)
 
 spec :: H.Spec
 spec = do
   H.describe "OneParamType () -> Char" $ do
-    specOPT @() @Char "optR" optR
-    specOPT @() @Char "optL" optL_
+    specOPT @() @Char "gopt" gopt
   H.describe "OneParamType Char -> Either String ()" $ do
-    specOPT @Char @(Either String ()) "optR" optR
-    specOPT @Char @(Either String ()) "optL" optL_
+    specOPT @Char @(Either String ()) "gopt" gopt
   H.describe "OneParamType String -> (Int, Either Integer Int)" $ do
-    specOPT @String @(Int, Either Integer Int) "optR" optR
-    specOPT @String @(Int, Either Integer Int) "optL" optL_
+    specOPT @String @(Int, Either Integer Int) "gopt" gopt
   H.describe "OneParamType [Maybe (Int, String)] -> (Int, [Either (Maybe ()) String])" $ do
-    specOPT @[Maybe (Int, String)] @(Int, [Either (Maybe ()) String]) "optR" optR
-    specOPT @[Maybe (Int, String)] @(Int, [Either (Maybe ()) String]) "optL" optL_
+    specOPT @[Maybe (Int, String)] @(Int, [Either (Maybe ()) String]) "gopt" gopt
diff --git a/test/Generics/Case/EitherSpec.hs b/test/Generics/Case/EitherSpec.hs
index cf6d7a7..896e205 100644
--- a/test/Generics/Case/EitherSpec.hs
+++ b/test/Generics/Case/EitherSpec.hs
@@ -7,12 +7,16 @@ import qualified Test.QuickCheck as Q
 import Test.QuickCheck.Function
 import Util
 
-type EitherFn a b r = (a -> r) -> (b -> r) -> Either a b -> r
+type EitherFn a b r = Either a b -> (a -> r) -> (b -> r) -> r
 
-type FunArgs a b r = '[Fun a r, Fun b r, Either a b]
+type FunArgs a b r = '[Either a b, Fun a r, Fun b r]
 
 type EitherFun a b r = Chain (FunArgs a b r) r
 
+manual :: EitherFn a b r
+manual (Left a) f _ = f a
+manual (Right b) _ g = g b
+
 specEither ::
   forall a b r.
   ( Show a
@@ -32,28 +36,21 @@ specEither ::
   H.Spec
 specEither name f =
   specG @(FunArgs a b r)
-    ("either", mkFn either)
+    ("either", mkFn manual)
     (name, mkFn f)
 
 mkFn ::
   EitherFn a b r ->
   EitherFun a b r
-mkFn e f g = e (applyFun f) (applyFun g)
-
-eitherL_ :: EitherFn a b r
-eitherL_ f g e = eitherL e f g
+mkFn e x f g = e x (applyFun f) (applyFun g)
 
 spec :: H.Spec
 spec = do
   H.describe "Either () Char -> Char" $ do
-    specEither @() @Char @Char "eitherR" eitherR
-    specEither @() @Char @Char "eitherL" eitherL_
+    specEither @() @Char @Char "eitherL" eitherL
   H.describe "Either Char String -> Either String ()" $ do
-    specEither @Char @String @(Either String ()) "eitherR" eitherR
-    specEither @Char @String @(Either String ()) "eitherL" eitherL_
+    specEither @Char @String @(Either String ()) "eitherL" eitherL
   H.describe "Either String (Maybe Integer) -> (Int, Either Integer Int)" $ do
-    specEither @String @(Maybe Integer) @(Int, Either Integer Int) "eitherR" eitherR
-    specEither @String @(Maybe Integer) @(Int, Either Integer Int) "eitherL" eitherL_
+    specEither @String @(Maybe Integer) @(Int, Either Integer Int) "eitherL" eitherL
   H.describe "Either [Maybe (Int, String)] Int -> (Int, [Either (Maybe ()) String])" $ do
-    specEither @[Maybe (Int, String)] @Int @(Int, [Either (Maybe ()) String]) "eitherR" eitherR
-    specEither @(Maybe (Int, String)) @Int @(Int, [Either (Maybe ()) String]) "eitherL" eitherL_
+    specEither @(Maybe (Int, String)) @Int @(Int, [Either (Maybe ()) String]) "eitherL" eitherL
diff --git a/test/Generics/Case/MaybeSpec.hs b/test/Generics/Case/MaybeSpec.hs
index 3ac75bb..ee86144 100644
--- a/test/Generics/Case/MaybeSpec.hs
+++ b/test/Generics/Case/MaybeSpec.hs
@@ -7,12 +7,16 @@ import qualified Test.QuickCheck as Q
 import Test.QuickCheck.Function
 import Util
 
-type MaybeFn a r = r -> (a -> r) -> Maybe a -> r
+type MaybeFn a r = Maybe a -> r -> (a -> r) -> r
 
-type FunArgs a r = '[r, Fun a r, Maybe a]
+type FunArgs a r = '[Maybe a, r, Fun a r]
 
 type MaybeFun a r = Chain (FunArgs a r) r
 
+manual :: MaybeFn a r
+manual Nothing r _ = r
+manual (Just a) _ f = f a
+
 specMaybe ::
   forall a r.
   ( Show a
@@ -28,28 +32,21 @@ specMaybe ::
   H.Spec
 specMaybe name f =
   specG @(FunArgs a r)
-    ("maybe", mkFn maybe)
+    ("maybe", mkFn manual)
     (name, mkFn f)
 
 mkFn ::
   MaybeFn a r ->
   MaybeFun a r
-mkFn f r fn = f r (applyFun fn)
-
-maybeL_ :: MaybeFn a r
-maybeL_ x y b = maybeL b x y
+mkFn f m r fn = f m r (applyFun fn)
 
 spec :: H.Spec
 spec = do
   H.describe "Maybe () -> Char" $ do
-    specMaybe @() @Char "maybeR" maybeR
-    specMaybe @() @Char "maybeL" maybeL_
+    specMaybe @() @Char "maybeL" maybeL
   H.describe "Maybe Char -> Either String ()" $ do
-    specMaybe @Char @(Either String ()) "maybeR" maybeR
-    specMaybe @Char @(Either String ()) "maybeL" maybeL_
+    specMaybe @Char @(Either String ()) "maybeL" maybeL
   H.describe "Maybe String -> (Int, Either Integer Int)" $ do
-    specMaybe @String @(Int, Either Integer Int) "maybeR" maybeR
-    specMaybe @String @(Int, Either Integer Int) "maybeL" maybeL_
+    specMaybe @String @(Int, Either Integer Int) "maybeL" maybeL
   H.describe "Maybe [Maybe (Int, String)] -> (Int, [Either (Maybe ()) String])" $ do
-    specMaybe @[Maybe (Int, String)] @(Int, [Either (Maybe ()) String]) "maybeR" maybeR
-    specMaybe @(Maybe (Int, String)) @(Int, [Either (Maybe ()) String]) "maybeL" maybeL_
+    specMaybe @(Maybe (Int, String)) @(Int, [Either (Maybe ()) String]) "maybeL" maybeL
diff --git a/test/Util.hs b/test/Util.hs
index 924ed2b..ce9372d 100644
--- a/test/Util.hs
+++ b/test/Util.hs
@@ -9,21 +9,23 @@ import qualified Test.Hspec as H
 import qualified Test.Hspec.QuickCheck as H
 import qualified Test.QuickCheck as Q
 
+newtype ChainF r xs = ChainF (NP I xs -> r)
+
 propG ::
   forall args r.
   (SListI args, All Show args, Eq r, Show r) =>
   (String, Chain args r) ->
   (String, Chain args r) ->
-  Chain args Q.Property
-propG (refName, refF) (name, f) =
-  toChain @args @Q.Property $ ChainF $ \args ->
-    let expected = applyChain (fromChain @args @r refF) args
-        actual = applyChain (fromChain f) args
-        argsS = unwords $ fmap ($ "") $ collapse_NP $ cmap_NP (Proxy @Show) (K . showsPrec 11 . unI) args
-        expS = unwords [refName, argsS, "=", show expected]
-        actS = unwords [name, argsS, "=", show actual]
-        s = unlines [expS, actS]
-    in  Q.counterexample s $ expected == actual
+  NP I args ->
+  Q.Property
+propG (refName, refF) (name, f) args =
+  let expected = fromChain @args @r refF args
+      actual = fromChain @args @r f args
+      argsS = unwords $ fmap ($ "") $ collapse_NP $ cmap_NP (Proxy @Show) (K . showsPrec 11 . unI) args
+      expS = unwords [refName, argsS, "=", show expected]
+      actS = unwords [name, argsS, "=", show actual]
+      s = unlines [expS, actS]
+  in  Q.counterexample s $ expected == actual
 
 testG ::
   forall args r.
@@ -31,7 +33,7 @@ testG ::
   (String, Chain args r) ->
   (String, Chain args r) ->
   Q.Property
-testG ref f = Q.property $ fromChain @args @Q.Property $ propG @args @r ref f
+testG ref f = Q.property @(ChainF Q.Property args) $ ChainF $ propG @args @r ref f
 
 specG ::
   forall args r.