packages feed

generic-case (empty) → 0.1.0.0

raw patch · 12 files changed

+906/−0 lines, 12 filesdep +QuickCheckdep +basedep +generic-case

Dependencies added: QuickCheck, base, generic-case, generics-sop, hspec, sop-core

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for generic-case++## 0.1.0.0 -- 2025-2-26++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2025, Frederick Pringle++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Frederick Pringle nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ generic-case.cabal view
@@ -0,0 +1,89 @@+cabal-version:      3.0+name:               generic-case+version:            0.1.0.0+synopsis:           Generic case analysis+description:+  Generic case analysis in the vein of 'maybe', 'either' and 'bool',+  using [generics-sop](https://hackage.haskell.org/package/generics-sop).++  See the module documentation in "Generics.Case".++license:            BSD-3-Clause+license-file:       LICENSE+author:             Frederick Pringle+maintainer:         freddyjepringle@gmail.com+copyright:          Copyright(c) Frederick Pringle 2025+homepage:           https://github.com/fpringle/generic-case+category:           Generics+build-type:         Simple+extra-doc-files:    CHANGELOG.md+tested-with:+  GHC == 9.10.1+  GHC == 9.8.2+  GHC == 9.6.5+  GHC == 9.4.8+  GHC == 9.2.8+  GHC == 9.0.2+  GHC == 8.10.7+  GHC == 8.6.5++source-repository head+  type:     git+  location: https://github.com/fpringle/generic-case.git++common warnings+  ghc-options: -Wall++common deps+  build-depends:+    , base >= 4 && < 5+    , sop-core >= 0.4.0.1 && < 0.6+    , generics-sop >= 0.4 && < 0.6++common extensions+  default-extensions:+    FlexibleContexts+    FlexibleInstances+    LambdaCase+    ScopedTypeVariables+    TypeApplications+    DataKinds+    AllowAmbiguousTypes+    TypeFamilies+    TypeOperators+    UndecidableInstances++library+  import:+      warnings+    , deps+    , extensions+  exposed-modules:+      Generics.Case+      Generics.Chain+  hs-source-dirs:   src+  default-language: Haskell2010++test-suite generic-case-test+  import:+      warnings+    , deps+    , extensions+  default-language: Haskell2010+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Spec.hs+  other-modules:+      Util+      Generics.Case.BoolSpec+      Generics.Case.MaybeSpec+      Generics.Case.EitherSpec+      Generics.Case.Custom.NoParamTypeSpec+      Generics.Case.Custom.OneParamTypeSpec+  build-tool-depends:+      hspec-discover:hspec-discover+  ghc-options:      -Wno-orphans+  build-depends:+    , generic-case+    , QuickCheck+    , hspec
+ src/Generics/Case.hs view
@@ -0,0 +1,240 @@+{- | Generic case analysis using [generics-sop](https://hackage.haskell.org/package/generics-sop).++"Case analysis" functions are those which take one function for each constructor of a sum type,+examine a value of that type, and call the relevant function depending on which constructor was+used to build that type. Examples include 'maybe', 'either' and 'Data.Bool.bool'.++It's often useful to define similar functions on user-defined sum types, which is boring at best+and error-prone at worst. This module gives us these functions for any type which+implements 'Generic'.++For any single-constructor types, such as tuples, this gives us generic uncurrying without+any extra effort - see 'tupleL', 'tuple3L'.++== Example++Let's use @These@ from+[these](https://hackage.haskell.org/package/these) as an example.+First we need an instance of 'Generic', which we can derive.++@+{\-# LANGUAGE DeriveGeneric #-\}+import qualified GHC.Generics as G+import Generics.SOP (Generic)++data These a b+  = This a+  | That b+  | These a b+  deriving (Show, Eq, G.Generic)++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 '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 ->+  _ -> _ -> _ ->+  c+@++What are the types of those 3 functions? For each constructor, we make a function type taking+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+  c+@++Finally, we add the implementation, which is just 'gcase':++@+these ::+  forall a b c.+  These a b ->+  (a -> c) ->+  (b -> c) ->+  (a -> b -> c) ->+  c+these = gcase+@++Note that we could have written the entire thing more succintly using 'Analysis':++@+these ::+  forall a b c.+  Analysis (These a b) c+these = gcase+@+-}+module Generics.Case+  ( -- * Generic case analysis+    Analysis+  , gcase++    -- * Examples++    -- ** Maybe+  , maybeL++    -- ** Either+  , eitherL++    -- ** Bool+  , boolL++    -- ** Tuples+  , tupleL+  , tuple3L++    -- ** Lists+  , listL++    -- ** Non-empty lists+  , nonEmptyL+  )+where++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 before the functions.++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! Analysis (Maybe a) r+Analysis (Maybe a) r :: *+= Maybe a -> r -> (a -> r) -> r+@+-}+type Analysis a r = a -> Chains (Code a) r++{- | 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.+-}+gcase ::+  forall a r.+  (Generic a) =>+  Analysis a r+gcase = applyChains @(Code a) @r . unSOP . from++------------------------------------------------------------+-- Examples++{- | Same as 'maybe', except the 'Maybe' comes before the case functions.++Equivalent type signature:++@+maybeL :: forall a r. Analysis (Maybe a) r+@++The implementation is just:++@+maybeL = gcase @(Maybe a)+@+-}+maybeL :: forall a r. Maybe a -> r -> (a -> r) -> r+maybeL = gcase++{- | Same as 'either', except the 'Either' comes before the case functions.++Equivalent type signature:++@+eitherL :: forall a b r. 'Analysis' (Either a b) r+@++The implementation is just:++@+eitherL = gcase+@+-}+eitherL :: forall a b r. Either a b -> (a -> r) -> (b -> r) -> r+eitherL = gcase++{- | Same as 'Data.Bool.bool', except the 'Bool' comes before the case functions.++Equivalent type signature:++@+boolL :: forall r. 'Analysis' Bool r+@++The implementation is just:++@+boolL = gcase+@+-}+boolL :: forall r. Bool -> r -> r -> r+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@, except the list comes before the case functions.++Equivalent type signature:++@+listL :: forall a r. 'Analysis' [a] r+@+-}+listL :: forall a r. [a] -> r -> (a -> [a] -> r) -> r+listL = gcase++{- | Case analysis on a tuple. Same as 'uncurry', except the tuple comes before the case function.++Equivalent type signature:++@+tupleL :: forall a b r. 'Analysis' (a, b) r+@+-}+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@, except the tuple comes before the case function.++Equivalent type signature:++@+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 = gcase++{- | Case analysis on a non-empty list.++Equivalent type signature:++@+nonEmptyL :: forall a r. 'Analysis' (NonEmpty a) r+@+-}+nonEmptyL :: forall a r. NonEmpty a -> (a -> [a] -> r) -> r+nonEmptyL = gcase
+ src/Generics/Chain.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE EmptyCase #-}++{- | Uniform representation + handling of n-ary functions.++This module gives us types and functions (both value- and type-level) to work+with n-ary functions.+The following are all function types, yet have very different shapes:++@+f1 :: Int -> Int+f1 = undefined+f2 :: a -> (b, a) -> c+f2 = undefined+f3 :: a -> (a -> a) -> (a -> a -> a) -> a+f3 = undefined+@++However there are 2 ways we can "unify" these into a common structure.+Both ways involve diving the function type into arguments (e.g. @Int ->@,+@a -> (b, a) ->@ and @a -> (a -> a) -> (a -> a -> a) ->@), and result types+(e.g. @Int@, @c@ and @a@).++The first way is to see these functions as right-associative folds.+Imagine a type-level function directly corresponding to 'foldr':++@+type family Foldr cons xs nil where+  Foldr cons '[] nil = nil+  Foldr cons (x ': xs) nil = cons x (Foldr cons xs nil)+@++Then using the function arrow @(->)@ for @cons@, the result type of our function+for @nil@ and the list of arguments for @xs@:++@+f1_ :: Foldr (->) '[Int] Int+f1_ = f1+f2_ :: Foldr (->) '[a, (b, a)] c+f2_ = f2+f3_ :: Foldr (->) '[a, a -> a, a -> a -> a] a+f3_ = f3+@++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.++@+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_+@++'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. Maybe a -> 'Chains' '[ '[], '[a]] r+maybe' m r f = 'maybe' r f m++either' :: forall a b r. Either a b -> 'Chains' '[ '[a], '[b]] r+either' e fa fb = 'either' fa fb e++bool' :: forall r. Bool -> 'Chains' '[ '[], '[]] r+bool' b f t = 'Data.Bool.bool' f t b+@+-}+module Generics.Chain+  ( -- * Representation of n-ary functions+    Chain+  , toChain+  , fromChain++    -- * Functions of functions+  , Chains+  , applyChains+  , constChain+  )+where++import Data.SOP++{- | 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+  ~ (x -> y -> z -> r)+@+-}+type family Chain xs r where+  Chain '[] r = r+  Chain (x ': xs) r = x -> Chain xs r++{- | Convert from type family 'Chain' to a function of a product 'NP'.++Inverse of 'toChain'.+-}+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 a function of a product, to type family 'Chain'.++e.g.++@+productChain :: 'NP' 'I' '[Int, Maybe Char] -> String+productChain ('I' n :* 'I' mChar :* Nil) = show n <> " " <> show mChar++chain :: Int -> Maybe Char -> String+chain = toChain productChain+@+-}+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 $ \xs -> f (I x :* xs)++{- | The next level up from 'Chain': now we represent a function of functions.++@+Chains '[ '[x,y], '[z], '[]] r+  ~ Chain '[x,y] r -> Chain '[z] r -> Chain '[] r -> r+  ~ (x -> y -> r)  -> (z -> r)     -> r           -> r+@++In an ideal world, we'd be able to write:++@+type Chains xss r = Chain (Map (\xs -> Chain xs r) xss) r+@+-}+type family Chains xss r where+  Chains '[] r = r+  Chains (xs ': xss) r = Chain xs r -> Chains xss r++{- | Apply a series of chains. Used to implement 'Generics.Case.gcase'.++You can think of the signature and implementation of this function as being:++@+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+@+-}+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++{- | 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.++You can think of the signature and implementation of this function (ignoring the 'Shape',+which just helps GHC understand the recursion) as being:++@+applyChains ::+  r ->+  Chains xs1 r ->+  Chains xs2 r ->+  ... ->+  Chains xsn r ->+  r+applyChains r _ _ ... _ = r+@+-}+constChain :: forall xss r. r -> Shape xss -> Chains xss r+constChain r = \case+  ShapeNil -> r+  ShapeCons s -> \_ -> constChain @_ @r r s
+ test/Generics/Case/BoolSpec.hs view
@@ -0,0 +1,33 @@+module Generics.Case.BoolSpec (spec) where++import Data.Bool+import Generics.Case+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 r.+  (Show r, Eq r, Q.Arbitrary r) =>+  String ->+  BoolFn r ->+  H.Spec+specBool name f = specG @(FunArgs r) ("bool", manual) (name, f)++spec :: H.Spec+spec = do+  H.describe "()" $ do+    specBool @() "boolL" boolL+  H.describe "Char" $ do+    specBool @Char "boolL" boolL+  H.describe "String" $ do+    specBool @String "boolL" boolL+  H.describe "[Maybe (Int, String)]" $ do+    specBool @[Maybe (Int, String)] "boolL" boolL
+ test/Generics/Case/Custom/NoParamTypeSpec.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveGeneric #-}++module Generics.Case.Custom.NoParamTypeSpec (spec) where++import qualified GHC.Generics as G+import Generics.Case+import Generics.Chain+import qualified Generics.SOP as SOP+import qualified Test.Hspec as H+import qualified Test.QuickCheck as Q+import Test.QuickCheck.Function+import Util++data NoParamType+  = NPT1+  | NPT2 Int+  | NPT3 String Char+  deriving (Show, Eq, G.Generic)++instance SOP.Generic NoParamType++instance Q.Arbitrary NoParamType where+  arbitrary =+    Q.oneof+      [ pure NPT1+      , NPT2 <$> Q.arbitrary+      , NPT3 <$> Q.arbitrary <*> Q.arbitrary+      ]+  shrink = Q.genericShrink++type NPTFn r = NoParamType -> r -> (Int -> r) -> (String -> Char -> r) -> r++type FunArgs r = '[NoParamType, r, Fun Int r, Fun String (Fun Char r)]++type NPTFun r = Chain (FunArgs r) r++manual :: NPTFn r+manual npt r fromInt fromStringChar = case npt of+  NPT1 -> r+  NPT2 int -> fromInt int+  NPT3 string char -> fromStringChar string char++nptL :: NPTFn r+nptL = gcase @NoParamType++specNPT ::+  forall r.+  ( Q.Arbitrary r+  , Show r+  , Eq r+  ) =>+  String ->+  NPTFn r ->+  H.Spec+specNPT name f =+  specG @(FunArgs r)+    ("manual", mkFn manual)+    (name, mkFn f)++mkFn ::+  NPTFn r ->+  NPTFun r+mkFn f npt' r f1 f2 = f npt' r (applyFun f1) (applyFun <$> applyFun f2)++spec :: H.Spec+spec = do+  H.describe "()" $ do+    specNPT @() "nptL" nptL+  H.describe "Char" $ do+    specNPT @Char "nptL" nptL+  H.describe "String" $ do+    specNPT @String "nptL" nptL+  H.describe "[Maybe (Int, String)]" $ do+    specNPT @[Maybe (Int, String)] "nptL" nptL
+ test/Generics/Case/Custom/OneParamTypeSpec.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveGeneric #-}++module Generics.Case.Custom.OneParamTypeSpec (spec) where++import qualified GHC.Generics as G+import Generics.Case+import Generics.Chain+import qualified Generics.SOP as SOP+import qualified Test.Hspec as H+import qualified Test.QuickCheck as Q+import Test.QuickCheck.Function+import Util++data OneParamType a+  = OPT1 a+  | OPT2 (Maybe a)+  | OPT3 a a+  deriving (Show, Eq, G.Generic)++instance SOP.Generic (OneParamType a)++instance (Q.Arbitrary a) => Q.Arbitrary (OneParamType a) where+  arbitrary =+    Q.oneof+      [ OPT1 <$> Q.arbitrary+      , OPT2 <$> Q.arbitrary+      , OPT3 <$> Q.arbitrary <*> Q.arbitrary+      ]+  shrink = Q.genericShrink++type OPTFn a r = OneParamType a -> (a -> r) -> (Maybe a -> r) -> (a -> a -> r) -> r++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 opt fromA fromM fromAs = case opt of+  OPT1 a -> fromA a+  OPT2 m -> fromM m+  OPT3 a1 a2 -> fromAs a1 a2++gopt :: forall a r. OPTFn a r+gopt = gcase @(OneParamType a)++specOPT ::+  forall a r.+  ( Show a+  , Function a+  , Q.CoArbitrary a+  , Q.Arbitrary a+  , Q.Arbitrary r+  , Show r+  , Eq r+  ) =>+  String ->+  OPTFn a r ->+  H.Spec+specOPT name f =+  specG @(FunArgs a r)+    ("manual", mkFn manual)+    (name, mkFn f)++mkFn ::+  forall a r.+  OPTFn a r ->+  OPTFun a r+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 "gopt" gopt+  H.describe "OneParamType Char -> Either String ()" $ do+    specOPT @Char @(Either String ()) "gopt" gopt+  H.describe "OneParamType String -> (Int, Either Integer Int)" $ do+    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]) "gopt" gopt
+ test/Generics/Case/EitherSpec.hs view
@@ -0,0 +1,56 @@+module Generics.Case.EitherSpec (spec) where++import Generics.Case+import Generics.Chain+import qualified Test.Hspec as H+import qualified Test.QuickCheck as Q+import Test.QuickCheck.Function+import Util++type EitherFn a b r = Either a b -> (a -> r) -> (b -> r) -> r++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+  , Function a+  , Q.CoArbitrary a+  , Q.Arbitrary a+  , Show b+  , Function b+  , Q.CoArbitrary b+  , Q.Arbitrary b+  , Q.Arbitrary r+  , Show r+  , Eq r+  ) =>+  String ->+  EitherFn a b r ->+  H.Spec+specEither name f =+  specG @(FunArgs a b r)+    ("either", mkFn manual)+    (name, mkFn f)++mkFn ::+  EitherFn a b r ->+  EitherFun a b r+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 "eitherL" eitherL+  H.describe "Either Char String -> Either String ()" $ do+    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) "eitherL" eitherL+  H.describe "Either [Maybe (Int, String)] Int -> (Int, [Either (Maybe ()) String])" $ do+    specEither @(Maybe (Int, String)) @Int @(Int, [Either (Maybe ()) String]) "eitherL" eitherL
+ test/Generics/Case/MaybeSpec.hs view
@@ -0,0 +1,52 @@+module Generics.Case.MaybeSpec (spec) where++import Generics.Case+import Generics.Chain+import qualified Test.Hspec as H+import qualified Test.QuickCheck as Q+import Test.QuickCheck.Function+import Util++type MaybeFn a r = Maybe a -> r -> (a -> r) -> r++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+  , Function a+  , Q.Arbitrary r+  , Q.CoArbitrary a+  , Q.Arbitrary a+  , Show r+  , Eq r+  ) =>+  String ->+  MaybeFn a r ->+  H.Spec+specMaybe name f =+  specG @(FunArgs a r)+    ("maybe", mkFn manual)+    (name, mkFn f)++mkFn ::+  MaybeFn a r ->+  MaybeFun a r+mkFn f m r fn = f m r (applyFun fn)++spec :: H.Spec+spec = do+  H.describe "Maybe () -> Char" $ do+    specMaybe @() @Char "maybeL" maybeL+  H.describe "Maybe Char -> Either String ()" $ do+    specMaybe @Char @(Either String ()) "maybeL" maybeL+  H.describe "Maybe String -> (Int, Either Integer Int)" $ do+    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]) "maybeL" maybeL
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Util.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DerivingVia #-}++module Util where++import Data.SOP+import Data.SOP.NP+import Generics.Chain+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) ->+  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.+  (SListI args, All Show args, Eq r, Show r, Q.Arbitrary r, All Q.Arbitrary args) =>+  (String, Chain args r) ->+  (String, Chain args r) ->+  Q.Property+testG ref f = Q.property @(ChainF Q.Property args) $ ChainF $ propG @args @r ref f++specG ::+  forall args r.+  (SListI args, All Show args, Eq r, Show r, Q.Arbitrary r, All Q.Arbitrary args) =>+  (String, Chain args r) ->+  (String, Chain args r) ->+  H.Spec+specG (refName, refF) (name, f) =+  H.prop (name <> " = " <> refName) $ testG @args @r (refName, refF) (name, f)++instance+  (SListI xs, All Show xs, Q.Testable r, All Q.Arbitrary xs) =>+  Q.Testable (ChainF r xs)+  where+  property (ChainF chain) = case sList @xs of+    SNil -> Q.property $ chain Nil+    SCons -> Q.property $ \x -> ChainF $ \xs -> chain (I x :* xs)