tuple-classes 1.0.1 → 1.0.2
raw patch · 8 files changed
+551/−259 lines, 8 filesdep +lensdep +microlens
Dependencies added: lens, microlens
Files
- CHANGELOG.md +12/−0
- README.md +6/−5
- src/Data/Tuple/Classes.hs +53/−13
- src/Data/Tuple/Classes/TH.hs +412/−234
- test/DocTest01.hs +9/−4
- test/DocTest02.hs +2/−1
- test/Spec.hs +37/−1
- tuple-classes.cabal +20/−1
CHANGELOG.md view
@@ -1,4 +1,16 @@ # Changelog and Acknowledgments +## 1.0.2+* Added microlens (or, with `lens` flag, lens) dependency.+ * `uncurriedN` and `uncurriedN'` `Lens`es (or `Iso`s)+* Added strict tuple instances to achieve parity with `Pair`.+ * `Each`+ * `Field1`, `Field2`, etc., however many are offered by the library providing optics+ * many more+* Fixed build issue with older template-haskell versions.++## 1.0.1+* Fixed build issue with older base versions that don't export `foldl'` in the Prelude.+ ## 1.0.0 * Initial release.
README.md view
@@ -8,7 +8,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} -import Data.Tuple.Classes (curryN', uncurryN')+import Data.Tuple.Classes (uncurriedN')+import Lens.Micro (over) -- Function wrapper that expects a unary function printArgAndRun :: (Show a) => (a -> IO b) -> a -> IO b@@ -22,10 +23,9 @@ putStrLn title print $ i + j --- We can adapt them+-- We can adapt it printArgsTitleAndSum :: String -> Int -> Int -> IO ()-printArgsTitleAndSum =- curryN' @3 $ printArgAndRun $ uncurryN' @3 printTitleAndSum+printArgsTitleAndSum = over (uncurriedN' @3) printArgAndRun printTitleAndSum main :: IO () main = printArgsTitleAndSum "Important identity" 26885 15184@@ -46,9 +46,10 @@ consTuple :: (TupleAt 1 a t u) => a -> t -> u consTuple = tupleInsert @1+infixr `consTuple` main :: IO ()-main = print $ consTuple 'x' $ consTuple False ("sequitur", "quodlibet")+main = print $ 'x' `consTuple` False `consTuple` ("sequitur", "quodlibet") ``` ```
src/Data/Tuple/Classes.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ImplicitParams #-}@@ -8,14 +9,14 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Data.Tuple.Classes (- -- | We present utilities here for generalized handling of tuples:+ -- | Generalized tuple-related utilities: -- -- * inserting and removing fields -- * converting /n/-ary functions to unary and vice versa -- * re-exports of smaller tuples -- * larger strict tuples with relevant instances --- -- We consider `Identity` the canonical strict tuple insofar as it adds no extra laziness.+ -- We consider `Identity` the canonical strict 1-tuple. -- -- === __Discussion__ --@@ -45,7 +46,7 @@ -- Arity a = 0 -- -- arity :: (KnownNat (Arity f)) => f -> Natural- -- arity _ = natVal $ Proxy @(Arity a)+ -- arity _ = natVal $ Proxy @(Arity f) -- @ -- -- but this falls short.@@ -56,7 +57,7 @@ -- >>> arity print -- 1 -- >>> arity id- -- • No instance for ‘KnownNat (1 + Arity a0)’+ -- • No instance for ‘KnownNat (1 + Arity f0)’ -- -- For more food for thought, see [this sketch](https://bin.mangoiv.com/note?id=d204d07f-6292-4eb7-9aff-4cabc78394b9) for Haskell keyword arguments. --@@ -68,6 +69,8 @@ -- * Generalized uncurrying UncurryN(..),+ uncurriedN,+ uncurriedN', -- * Re-exports Solo(..),@@ -85,10 +88,15 @@ StrictTuple9(..), ) where +import Data.Strict.Tuple qualified as Strict+import Data.Tuple (Solo(..))+import GHC.TypeNats (Nat)+#if defined(LENS)+import Control.Lens+#else import Data.Functor.Identity (Identity(..))-import Data.Strict.Tuple qualified as Strict-import Data.Tuple (Solo(..))-import GHC.TypeNats (Nat)+import Lens.Micro+#endif import Data.Tuple.Classes.TH @@ -104,29 +112,54 @@ -- | A unary function isomorphic to @c@. -- The argument is a lazy tuple. type UncurriedN n c+ -- | Same, but the tuple is strict. type UncurriedN' n c+ -- | Convert a function taking @n@ arguments to a function taking a single lazy @n@-tuple. -- -- > uncurryN :: (a -> b -> ... -> r) -> (a, b, ...) -> r --- -- If the function @cur _ _ ... = k@ ignores its arguments, then @uncurryN cur ⊥ = k@.+ -- Instances defined in this library ensure, given a function @cur _ _ ... = k@ which ignores its arguments, that @uncurryN cur ⊥ = k@. uncurryN :: c -> UncurriedN n c+ -- | Convert a function taking a single lazy @n@-tuple to a function taking @n@ arguments. -- -- > curryN :: ((a, b, ...) -> r) -> a -> b -> ... -> r curryN :: UncurriedN n c -> c+ -- | Convert a function taking @n@ arguments to a function taking a single strict @n@-tuple. -- -- > uncurryN' :: (a -> b -> ... -> r) -> StrictTupleN a b ... -> r --- -- If the function @cur _ _ ... = k@ ignores its arguments, then @uncurryN' cur ⊥ = k@.+ -- Instances defined in this library ensure, given a function @cur _ _ ... = k@ which ignores its arguments, that @uncurryN' cur ⊥ = k@. uncurryN' :: c -> UncurriedN' n c+ -- | Convert a function taking a single strict @n@-tuple to a function taking @n@ arguments. -- -- > curryN' :: (StrictTupleN a b ... -> r) -> a -> b -> ... -> r curryN' :: UncurriedN' n c -> c +-- | Operate on an @n@-ary function as a unary function taking a lazy tuple argument.+uncurriedN :: forall n c d. (UncurryN n c, UncurryN n d) =>+#if defined(LENS)+ Iso c d (UncurriedN n c) (UncurriedN n d)+uncurriedN = iso (uncurryN @n) (curryN @n)+#else+ Lens c d (UncurriedN n c) (UncurriedN n d)+uncurriedN f = fmap (curryN @n) . f . (uncurryN @n)+#endif++-- | Same, but the tuple is strict.+uncurriedN' :: forall n c d. (UncurryN n c, UncurryN n d) =>+#if defined(LENS)+ Iso c d (UncurriedN' n c) (UncurriedN' n d)+uncurriedN' = iso (uncurryN' @n) (curryN' @n)+#else+ Lens c d (UncurriedN' n c) (UncurriedN' n d)+uncurriedN' f = fmap (curryN' @n) . f . (uncurryN' @n)+#endif+ -- | Inserting and removing tuple fields. -- Specify @i@ via @TypeApplications@/@DataKinds@. --@@ -139,6 +172,8 @@ -- > uncurry (tupleInsert @i) . tupleRemove @i = id -- -- The valid range of @i@ is \[1, /n/], where /n/ is the width of @u@.+--+-- We do not provide an instance for inserting into the zero-tuple @()@, because the strictness is ambiguous. class TupleAt (i :: Nat) a t u | i a t -> u, i u -> a t where -- | Insert an @a@ into @t@ at @i@ and return the widened tuple @u@. -- Upon insertion, any fields at indices >=@i@ will slide to the right to make room.@@ -148,10 +183,16 @@ -- >>> tupleInsert @2 'x' (Identity 67) -- 67 :!: 'x' --- -- For lazy tuples, @`ith` \@i \(tupleInsert \@i x ⊥) = x@.+ -- Instances defined in this library behave differently based on strictness.+ -- Given a function @cur _ _ ... = k@ which ignores its arguments, we ensure: --- -- For strict tuples, @ith \@i \(tupleInsert \@i x ⊥) = ⊥@.+ -- +--------------+----------------------------------------++ -- | Lazy tuple | @`ith` \@i \(tupleInsert \@i x ⊥) = x@ |+ -- +--------------+----------------------------------------++ -- | Strict tuple | @ith \@i \(tupleInsert \@i x ⊥) = ⊥@ |+ -- +--------------+----------------------------------------+ tupleInsert :: a -> t -> u+ -- | Remove an @a@ from @u@ at @i@ and return both it and the remaining tuple @t@. -- Upon removal, any fields at indices >@i@ will slide to the left to close the gap. --@@ -166,8 +207,7 @@ -- Foo -- -- This is a convenience function defined as @fst . tupleRemove \@i@.--- For typeclasses purpose-built for accessing tuple fields, consider [lens\'s @Field1@ and the like](https://hackage-content.haskell.org/package/lens-5.3.6/docs/Control-Lens-Tuple.html).--- We do not wish to duplicate that here; it is already duplicated by (the excellent) [microlens](https://hackage-content.haskell.org/package/microlens-0.5.0.0/docs/Lens-Micro-FieldN.html).+-- For purpose-built tuple field accessors, consider `_1` and the like. ith :: forall i a t u. (TupleAt i a t u) => u -> a ith = fst . tupleRemove @i
src/Data/Tuple/Classes/TH.hs view
@@ -1,5 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TemplateHaskell #-} module Data.Tuple.Classes.TH ( makeStrictTupleAndInsts,@@ -7,23 +8,43 @@ makeTupleAtInsts, ) where -import Control.DeepSeq (NFData(..), NFData1, NFData2(..))-import Control.Monad (forM)-import Data.Bifoldable (Bifoldable(..))+import Control.DeepSeq (NFData(..), NFData1, NFData2(..))+import Control.Monad (forM)+import Data.Bifoldable (Bifoldable(..))+import Data.Bifunctor.Swap (Swap(..))+import Data.Binary (Binary(..))+import Data.Bitraversable (Bitraversable(..))+import Data.Data (Data)+import Data.Functor.Classes+import Data.Hashable (Hashable(..))+import Data.Hashable.Lifted (Hashable1, Hashable2(..))+import Data.Ix (Ix)+import Data.Strict.Classes (Strict(..))+import Data.Strict.Tuple (Pair(..))+import GHC.Generics (Generic, Generic1)+import GHC.Read qualified as Read+import Language.Haskell.TH hiding (Strict)+import Language.Haskell.TH.Syntax hiding (Strict)+import Text.Read (Read(..))+import Text.Read qualified as Read+#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif+#if defined(LENS)+import Control.Lens hiding (op)+#else import Data.Bifunctor (Bifunctor(..))-import Data.Bifunctor.Swap (Swap(..))-import Data.Binary (Binary(..))-import Data.Bitraversable (Bitraversable(..))-import Data.Foldable (foldl')-import Data.Functor.Classes (Eq1(..), Eq2(..)) import Data.Functor.Identity (Identity(..))-import Data.Hashable (Hashable)-import Data.Hashable.Lifted (Hashable1)-import Data.Strict.Classes (Strict(..))-import Data.Strict.Tuple (Pair(..))-import GHC.Generics (Generic, Generic1)-import Language.Haskell.TH hiding (Strict, strictType)+import Lens.Micro+import Lens.Micro.Internal qualified as Lens.Micro+#if !MIN_VERSION_microlens(0,5,0)+import Lens.Micro.Internal hiding (Strict)+#endif+#endif +dropLast :: Int -> [a] -> [a]+dropLast n = reverse . drop n . reverse+ strictTName :: Int -> Name strictTName 0 = ''() strictTName 1 = ''Identity@@ -36,31 +57,33 @@ strictDName 2 = '(:!:) strictDName n = strictTName n -dropLast :: (?n :: Int) => Int -> [a] -> [a]-dropLast u = take $ ?n - u+-- "StrictTuple3"+strictTupleSE :: (?n :: Int) => ExpQ+strictTupleSE = stringE $ nameBase $ strictDName ?n --- StrictTuple3-mkNames :: (?n :: Int) => (Enum a) => a -> (a -> String) -> [Name]+mkNames :: (?n :: Int, Enum a) => a -> (a -> String) -> [Name] mkNames x toName = map (mkName . toName) $ take ?n $ enumFrom x abc, xs, ys :: (?n :: Int) => [Name] -- a, b, c abc = mkNames 'a' (: [])--- x0, x1, x2-xs = mkNames (0 :: Int) $ ('x' :) . show--- y0, y1, y2-ys = mkNames (0 :: Int) $ ('y' :) . show+-- x1, x2, x3+xs = mkNames (1 :: Int) $ ('x' :) . show+-- y1, y2, y3+ys = mkNames (1 :: Int) $ ('y' :) . show -fName, gName, cur, unc :: Name-fName = mkName "f"-gName = mkName "g"-cur = mkName "cur"-unc = mkName "unc"+cur, unc :: Name+(cur, unc) = ("cur", "unc") & both %~ mkName -- !a banged :: Name -> BangTypeQ banged a = bangType (bang noSourceUnpackedness sourceStrict) (varT a) +-- contextT 1 ''Eq = (Eq a, Eq b)+contextT :: (?n :: Int) => Int -> Name -> TypeQ+contextT u ctor = foldl' appT (tupleT $ ?n - u) $+ map (\a -> conT ctor `appT` varT a) $ dropLast u abc+ -- StrictTuple3 a strictTupleUnsatT :: (?n :: Int) => Int -> TypeQ strictTupleUnsatT u =@@ -74,27 +97,83 @@ lazyTupleSatT :: (?n :: Int) => TypeQ lazyTupleSatT = foldl' appT (tupleT ?n) $ map varT abc --- StrictTuple3 x0 x1 x2+-- a+aT, bT :: TypeQ+(aT, bT) = ("a", "b") & both %~ varT . mkName++-- StrictTuple3 x1 x2 x3 strictTupleP :: (?n :: Int) => [Name] -> PatQ strictTupleP = conP (strictDName ?n) . map varP --- StrictTuple3 x0+-- StrictTuple3 x1 strictTupleUnsatE :: (?n :: Int) => Int -> ExpQ strictTupleUnsatE u = foldl' appE (conE $ strictDName ?n) $ dropLast u $ map varE xs --- StrictTuple3 x0 x1 x2+-- StrictTuple3 x1 x2 x3 strictTupleSatE :: (?n :: Int) => ExpQ strictTupleSatE = strictTupleUnsatE 0 +-- StrictTuple3 a a a+strictTupleAllSameT :: (?n :: Int) => TypeQ -> TypeQ+strictTupleAllSameT a = foldl' appT (conT $ strictTName ?n) (replicate ?n a)++-- {-# INLINE method #-}+inlineD :: Name -> DecQ+inlineD name = pragInlD name Inline FunLike AllPhases++-- StrictTuple3 <$> exp1 <*> exp2 <*> ...+applicativeE :: (?n :: Int) => [ExpQ] -> ExpQ+applicativeE expQs = foldl' accOpE (conE $ strictDName ?n) $ zip ops expQs where+ accOpE acc (op, expQ) = uInfixE acc op expQ+ ops = [| (<$>) |] : repeat [| (<*>) |]++-- x <> y+sappendE :: Name -> Name -> ExpQ+sappendE x y = [| $(varE x) <> $(varE y) |]++-- (1, ''Field1, '_1), (2, ''Field2, '_2), ...+fieldNNames :: [(Int, Name, Name)]+fieldNNames = $(+ let go i = do+ fieldI <- lookupTypeName $ "Field" ++ show i+ _i <- lookupValueName $ "_" ++ show i+ case liftA2 (i, , ) fieldI _i of+ Nothing -> return []+ Just iFieldI_i -> (iFieldI_i :) <$> go (i + 1)++ liftFieldNNames :: [(Int, Name, Name)] -> ExpQ+#if MIN_VERSION_template_haskell(2,22,1)+ liftFieldNNames = lift+#else+ liftFieldNNames = listE . map liftTriple++ liftTriple (i, fieldI, _i) = tupE [lift i, liftName fieldI, liftName _i]++ liftName (Name (OccName on) (NameG ns (PkgName pn) (ModName mn))) = [|+ Name+ (OccName $(stringE on))+ (NameG+ $(liftNameSpace ns)+ (PkgName $(stringE pn))+ (ModName $(stringE mn)))+ |]+ liftName _ = fail "not implemented"++ liftNameSpace VarName = [| VarName |]+ liftNameSpace TcClsName = [| TcClsName |]+ liftNameSpace _ = fail "not implemented"+#endif+ in go (1 :: Int) >>= liftFieldNNames)+ {- instance UncurryN 3 (a -> b -> c -> d) where type UncurriedN 3 (a -> b -> c -> d) = (a, b, c) -> d type UncurriedN' 3 (a -> b -> c -> d) = StrictTuple3 a b c -> d- uncurryN cur ~(x0, x1, x2) = cur x0 x1 x2- curryN unc x0 x1 x2 = unc (x0, x1, x2)- uncurryN' cur ~(StrictTuple3 x0 x1 x2) = cur x0 x1 x2- curryN' unc x0 x1 x2 = unc (StrictTuple3 x0 x1 x2)+ uncurryN cur ~(x1, x2, x3) = cur x1 x2 x3+ curryN unc x1 x2 x3 = unc (x1, x2, x3)+ uncurryN' cur ~(StrictTuple3 x1 x2 x3) = cur x1 x2 x3+ curryN' unc x1 x2 x3 = unc (StrictTuple3 x1 x2 x3) -} makeUncurryNInst :: (?n :: Int) => DecQ makeUncurryNInst =@@ -109,22 +188,19 @@ (map varP $ unc : xs) (normalB $ varE unc `appE` foldl' appE (conE ctor) (map varE xs)) []- in instanceD- (pure [])- [t| $(conT $ mkName "UncurryN") $nT $curT |]- [- tySynInstD $ tySynEqn- Nothing- [t| $(conT $ mkName "UncurriedN") $nT $curT |]- [t| $lazyTupleSatT -> $(varT d) |],- tySynInstD $ tySynEqn- Nothing- [t| $(conT $ mkName "UncurriedN'") $nT $curT |]- [t| $strictTupleSatT -> $(varT d) |],- funD (mkName "uncurryN") [uncurryClause $ tupleDataName ?n],- funD (mkName "curryN") [curryClause $ tupleDataName ?n],- funD (mkName "uncurryN'") [uncurryClause $ strictDName ?n],- funD (mkName "curryN'") [curryClause $ strictDName ?n]]+ in instanceD (pure []) [t| $(conT $ mkName "UncurryN") $nT $curT |] [+ tySynInstD $ tySynEqn+ Nothing+ [t| $(conT $ mkName "UncurriedN") $nT $curT |]+ [t| $lazyTupleSatT -> $(varT d) |],+ tySynInstD $ tySynEqn+ Nothing+ [t| $(conT $ mkName "UncurriedN'") $nT $curT |]+ [t| $strictTupleSatT -> $(varT d) |],+ funD (mkName "uncurryN") [uncurryClause $ tupleDataName ?n],+ funD (mkName "curryN") [curryClause $ tupleDataName ?n],+ funD (mkName "uncurryN'") [uncurryClause $ strictDName ?n],+ funD (mkName "curryN'") [curryClause $ strictDName ?n]] makeTupleAtInsts :: (?n :: Int) => DecsQ makeTupleAtInsts = fmap concat $ forM [1 .. ?n] $ \i -> do@@ -136,11 +212,11 @@ let tupleAtInst :: Name -> Name -> Name -> Name -> DecQ tupleAtInst removeType removeData insertType insertData = instanceD (pure [])- (foldl' appT (conT $ mkName "TupleAt") [- litT $ numTyLit $ fromIntegral i,- varT a,- foldl' appT (conT removeType) $ map varT abc',- foldl' appT (conT insertType) $ map varT abc])+ (conT (mkName "TupleAt")+ `appT` litT (numTyLit $ fromIntegral i)+ `appT` varT a+ `appT` foldl' appT (conT removeType) (map varT abc')+ `appT` foldl' appT (conT insertType) (map varT abc)) [ funD (mkName "tupleInsert") [clause [varP x, tildeP $ conP removeData $ map varP xs']@@ -155,9 +231,9 @@ sequence [ {-- instance TupleAt 1 b (a, c) (a, b, c) where- tupleInsert x1 ~(x0, x2) = (x0, x1, x2)- tupleRemove (x0, x1, x2) = (x1, (x0, x2))+ instance TupleAt 2 b (a, c) (a, b, c) where+ tupleInsert x2 ~(x1, x3) = (x1, x2, x3)+ tupleRemove (x1, x2, x3) = (x2, (x1, x3)) -} tupleAtInst (tupleTypeName $ ?n - 1)@@ -168,9 +244,9 @@ -- TODO This tilde makes implementation simpler and probably has no -- impact, but let's confirm that with benchmarks. {-- instance TupleAt 1 b (Pair a c) (StrictTuple3 a b c) where- tupleInsert x1 ~(x0 :!: x2) = StrictTuple3 x0 x1 x2- tupleRemove (StrictTuple3 x0 x1 x2) = (x1, x0 :!: x2)+ instance TupleAt 2 b (Pair a c) (StrictTuple3 a b c) where+ tupleInsert x2 ~(x1 :!: x3) = StrictTuple3 x1 x2 x3+ tupleRemove (StrictTuple3 x1 x2 x3) = (x2, x1 :!: x3) -} tupleAtInst (strictTName $ ?n - 1)@@ -180,12 +256,12 @@ makeStrictTupleAndInsts :: (?n :: Int) => DecsQ makeStrictTupleAndInsts = do- (x1, x2) <- case drop (?n - 2) xs of- [x1, x2] -> return (x1, x2)- _ -> fail "makeStrictTupleAndInsts: ?n < 2"+ ((x1, y1), (x2, y2)) <- case drop (?n - 2) $ zip xs ys of+ [xy1, xy2] -> return (xy1, xy2)+ _ -> fail "makeStrictTupleAndInsts: ?n < 2" {-- data StrictTuple4 a b c = StrictTuple4 a b c+ data StrictTuple3 a b c = StrictTuple3 a b c deriving (...) -} strictTupleDef <- dataD@@ -199,196 +275,298 @@ ''Ord, ''Read, ''Show,+ ''Bounded,+ ''Ix, ''Foldable, ''Functor, ''Traversable, ''Generic,- ''Generic1]]+ ''Generic1,+ ''Data]] {-- instance (Hashable a, Hashable b, Hashable c) => Hashable (StrictTuple3 a b c)+ instance Field2 (StrictTuple3 a b c) (StrictTuple3 a b' c) b b' where+ _2 f ~(StrictTuple3 x1 x2 x3) = f x2 <&> \x2' -> StrictTuple3 x1 x2' x3+ {-# INLINE _2 #-} -}- hashableInst <- instanceD- (cxt [[t| Hashable $(varT a) |] | a <- abc])- [t| Hashable $strictTupleSatT |]- []+ fieldNInsts <- forM (take ?n fieldNNames) $ \(i, fieldI, _i) -> do+ ((a, x), (a', x'), (a'bc, xs')) <- case splitAt (i - 1) $ zip abc xs of+ (_, []) -> fail "fieldNInsts: i > ?n"+ (ls, ax : rs) -> return (ax, a'x', unzip $ ls ++ a'x' : rs) where+ a'x' = ax & both %~ \name -> mkName $ nameBase name ++ "'"+ f <- newName "f"+ instanceD+ (pure [])+ (conT fieldI+ `appT` strictTupleSatT+ `appT` foldl' appT (conT $ strictTName ?n) (map varT a'bc)+ `appT` varT a+ `appT` varT a')+ [+ funD _i [clause+ [varP f, tildeP $ strictTupleP xs]+ (normalB $ [| fmap |]+ `appE` lam1E+ (varP x')+ (foldl' appE (conE $ strictDName ?n) $ map varE xs')+ `appE` (varE f `appE` varE x))+ []],+ inlineD _i] - {-- instance (Hashable a, Hashable b) => Hashable1 (StrictTuple3 a b)- -}- hashable1Inst <- instanceD- (cxt [[t| Hashable $(varT a) |] | a <- init abc])- [t| Hashable1 $(strictTupleUnsatT 1) |]- []+ otherInsts <- [d|+ {-+ instance (Eq a, Eq b) => Eq1 (StrictTuple3 a b) where+ -}+ instance $(contextT 1 ''Eq) => Eq1 $(strictTupleUnsatT 1) - {-- instance (Eq a, Eq b) => Eq1 (StrictTuple3 a b) where- liftEq = liftEq2 (==)- -}- eq1Inst <- instanceD- (cxt [[t| Eq $(varT a) |] | a <- init abc])- [t| Eq1 $(strictTupleUnsatT 1) |]- [funD 'liftEq [clause [] (normalB [| liftEq2 (==) |]) []]]+ {-+ instance (Eq a) => Eq2 (StrictTuple3 a) where+ liftEq2 f g (StrictTuple3 x1 x2 x3) (StrictTuple3 y1 y2 y3) =+ x1 == y1 && f x2 y2 && g x3 y3+ -}+ instance $(contextT 2 ''Eq) => Eq2 $(strictTupleUnsatT 2) where+ liftEq2 f g $(strictTupleP xs) $(strictTupleP ys) = $(foldr+ (\expQ r -> [| $expQ && $r |])+ [| f $(varE x1) $(varE y1) && g $(varE x2) $(varE y2) |]+ (dropLast 2 $+ let eqE x y = [| $(varE x) == $(varE y) |]+ in zipWith eqE xs ys)) - {-- instance (Eq a) => Eq2 (StrictTuple3 a) where- liftEq2 f g (StrictTuple3 x0 x1 x2) (StrictTuple3 y0 y1 y2) =- x0 == y0 && f x1 y1 && g x2 y2- -}- eq2Inst <- instanceD- (cxt [[t| Eq $(varT a) |] | a <- dropLast 2 abc])- [t| Eq2 $(strictTupleUnsatT 2) |]- [funD 'liftEq2 [clause- [varP fName, varP gName, strictTupleP xs, strictTupleP ys]- (normalB $ foldr- (\boolE r -> [| $boolE && $r |])- [|- $(varE fName) $(varE x1) $(varE $ ys !! (?n - 2)) &&- $(varE gName) $(varE x2) $(varE $ ys !! (?n - 1)) |]+ {-+ instance (Ord a, Ord b) => Ord1 (StrictTuple3 a b) where+ -}+ instance $(contextT 1 ''Ord) => Ord1 $(strictTupleUnsatT 1)++ {-+ instance (Ord a) => Ord2 (StrictTuple3 a) where+ liftCompare2 f g (StrictTuple3 x1 x2 x3) (StrictTuple3 y1 y2 y3) =+ x1 `compare` y1 <> f x2 y2 <> g x3 y3+ -}+ instance $(contextT 2 ''Ord) => Ord2 $(strictTupleUnsatT 2) where+ liftCompare2 f g $(strictTupleP xs) $(strictTupleP ys) = $(foldr+ (\expQ r -> [| $expQ <> $r |])+ [| f $(varE x1) $(varE y1) <> g $(varE x2) $(varE y2) |] (dropLast 2 $- zipWith (\x y -> [| $(varE x) == $(varE y) |]) xs ys))- []]]+ let compareE x y = [| $(varE x) `compare` $(varE y) |]+ in zipWith compareE xs ys)) - {-- instance (NFData a, NFData b, NFData c) => NFData (StrictTuple3 a b c)- -}- nfDataInst <- instanceD- (cxt [[t| NFData $(varT a) |] | a <- abc])- [t| NFData $strictTupleSatT |]- []+ {-+ instance (Show a, Show b) => Show1 (StrictTuple3 a b)+ -}+ instance $(contextT 1 ''Show) => Show1 $(strictTupleUnsatT 1) - {-- instance (NFData a, NFData b) => NFData1 (StrictTuple3 a b)- -}- nfData1Inst <- instanceD- (cxt [[t| NFData $(varT a) |] | a <- init abc])- [t| NFData1 $(strictTupleUnsatT 1) |]- []+ {-+ instance (Show a) => Show2 (StrictTuple3 a) where+ liftShowsPrec2 f _ g _ prec (StrictTuple3 x1 x2 x3) =+ showParen (prec > 10) $ showString "StrictTuple3"+ . showChar ' ' . showsPrec 11 x1+ . showChar ' ' . f 11 x2+ . showChar ' ' . g 11 x3+ -}+ instance $(contextT 2 ''Show) => Show2 $(strictTupleUnsatT 2) where+ liftShowsPrec2 f _ g _ prec $(strictTupleP xs) =+ showParen (prec > 10) $(+ let unwordsE fE r = [| $fE . showChar ' ' . $r |]+ showsCtorE = [| showString $strictTupleSE |]+ showsPrecE x = [| showsPrec 11 $(varE x) |]+ mostFsE = map showsPrecE $ dropLast 2 xs+ in foldr1 unwordsE $ showsCtorE : mostFsE ++ [+ [| f 11 $(varE x1) |],+ [| g 11 $(varE x2) |]]) - {-- instance (NFData a) => NFData2 (StrictTuple3 a) where- liftRnf2 r s (StrictTuple3 x0 x1 x2) = x0 `seq` r x1 `seq` s x2- -}- nfData2Inst <- instanceD- (cxt [[t| NFData $(varT a) |] | a <- dropLast 2 abc])- [t| NFData2 $(strictTupleUnsatT 2) |]- [funD 'liftRnf2 [clause- [varP fName, varP gName, strictTupleP xs]- (normalB $ foldr+ {-+ instance (Read a, Read b) => Read1 (StrictTuple3 a b) where+ liftReadPrec = liftReadPrec2 readPrec readListPrec+ liftReadListPrec = liftReadListPrecDefault+ liftReadList = liftReadListDefault+ -}+ instance $(contextT 1 ''Read) => Read1 $(strictTupleUnsatT 1) where+ liftReadPrec = liftReadPrec2 readPrec readListPrec+ liftReadListPrec = liftReadListPrecDefault+ liftReadList = liftReadListDefault++ {-+ instance (Read a) => Read2 (StrictTuple3 a) where+ liftReadPrec2 rp1 _ rp2 _ = readData $ do+ Read.expectP $ Read.Ident "StrictTuple3"+ Read.step $ StrictTuple3 <$> readPrec <*> rp1 <*> rp2+ -}+ instance $(contextT 2 ''Read) => Read2 $(strictTupleUnsatT 2) where+ liftReadPrec2 rp1 _ rp2 _ = readData $ do+ Read.expectP $ Read.Ident $(stringE $ nameBase $ strictDName ?n)+ Read.step $ $(applicativeE $ replicate (?n - 2) [| readPrec |])+ <*> rp1+ <*> rp2++ {-+ instance (NFData a, NFData b, NFData c) =>+ NFData (StrictTuple3 a b c)+ -}+ instance $(contextT 0 ''NFData) => NFData $strictTupleSatT++ {-+ instance (NFData a) => NFData2 (StrictTuple3 a) where+ liftRnf2 f g (StrictTuple3 x1 x2 x3) = x1 `seq` f x2 `seq` g x3+ -}+ instance $(contextT 2 ''NFData) => NFData2 $(strictTupleUnsatT 2) where+ liftRnf2 f g $(strictTupleP xs) = $(foldr (\x r -> [| rnf $(varE x) `seq` $r |])- [| $(varE fName) $(varE x1) `seq` $(varE gName) $(varE x2) |]+ [| f $(varE x1) `seq` g $(varE x2) |] (dropLast 2 xs))- []]] - {-- instance (Binary a, Binary b, Binary c) => Binary (StrictTuple3 a b c) where- put = put . toLazy- get = toStrict <$> get- -}- binaryInst <- instanceD- (cxt [[t| Binary $(varT a) |] | a <- abc])- [t| Binary $strictTupleSatT |]- [- funD 'put [clause [] (normalB [| put . toLazy |]) []],- funD 'get [clause [] (normalB [| toStrict <$> get |]) []]]+ {-+ instance (NFData a, NFData b) => NFData1 (StrictTuple3 a b)+ -}+ instance $(contextT 1 ''NFData) => NFData1 $(strictTupleUnsatT 1) - {-- instance (Monoid a, Monoid b) => Applicative (StrictTuple3 a b) where- pure = StrictTuple3 mempty mempty- StrictTuple3 x0 x1 x2 <*> StrictTuple3 y0 y1 y2 =- StrictTuple (x0 <> y0) (x1 <> y1) (x2 y2)- -}- applicativeInst <- instanceD- (cxt [[t| Monoid $(varT a) |] | a <- init abc])- [t| Applicative $(strictTupleUnsatT 1) |]- [- funD 'pure [clause- [varP $ last xs]- (normalB $ foldl' appE (conE $ strictDName ?n) $- replicate (?n - 1) [| mempty |] ++ [varE $ last xs])- []],- funD '(<*>) [clause- [strictTupleP xs, strictTupleP ys]- (normalB $ foldl' appE (conE $ strictDName ?n) $- let mappendE x y = [| $(varE x) <> $(varE y) |]- mappendE's = init $ zipWith mappendE xs ys- in mappendE's ++ [varE (last xs) `appE` varE (last ys)])- []]]+ {-+ instance (Semigroup a, Semigroup b, Semigroup c) =>+ Semigroup (StrictTuple3 a b c) where+ StrictTuple3 x1 x2 x3 <> StrictTuple3 y1 y2 y3 =+ StrictTuple3 (x1 <> y1) (x2 <> y2) (x3 <> y3)+ -}+ instance $(contextT 0 ''Semigroup) => Semigroup $strictTupleSatT where+ $(strictTupleP xs) <> $(strictTupleP ys) =+ $(foldl' appE (conE $ strictDName ?n) $ zipWith sappendE xs ys) - {-- instance (Monoid a, Monoid b) => Monad (StrictTuple3 a b) where- StrictTuple3 x0 x1 x2 >>= f = StrictTuple3 (x0 <> y0) (x1 <> y1) y2 where- StrictTuple3 y0 y1 y2 = f x2- -}- monadInst <- instanceD- (cxt [[t| Monoid $(varT a) |] | a <- init abc])- [t| Monad $(strictTupleUnsatT 1) |]- [funD '(>>=) [clause- [strictTupleP xs, varP fName]- (normalB $ foldl' appE (conE $ strictDName ?n) $- let mappendE x y = [| $(varE x) <> $(varE y) |]- in init (zipWith mappendE xs ys) ++ [varE $ last ys])- [valD- (strictTupleP ys)- (normalB $ varE fName `appE` varE (last xs))- []]]]+ {-+ instance (Monoid a, Monoid b, Monoid c) => Monoid (StrictTuple3 a b c) where+ mempty = StrictTuple3 mempty mempty mempty+ -}+ instance $(contextT 0 ''Monoid) => Monoid $strictTupleSatT where+ mempty = $(foldl' appE (conE $ strictDName ?n) $+ replicate ?n [| mempty |]) - otherInsts <-- let bifoldMapP = tildeP $ conP (strictDName ?n) $- replicate (?n - 2) wildP ++ [varP x1, varP x2]- in [d|- {-- instance Strict (a, b, c) (StrictTuple3 a b c) where- toStrict (x0, x1, x2) = StrictTuple3 x0 x1 x2- toLazy (StrictTuple3 x0 x1 x2) = (x0, x1, x2)- -}- instance Strict $lazyTupleSatT $strictTupleSatT where- toStrict $(tupP $ map varP xs) = $strictTupleSatE- toLazy $(strictTupleP xs) = $(tupE $ map varE xs)+ {-+ instance (Monoid a, Monoid b) => Applicative (StrictTuple3 a b) where+ pure = StrictTuple3 mempty mempty+ StrictTuple3 x1 x2 x3 <*> StrictTuple3 y1 y2 y3 =+ StrictTuple (x1 <> y1) (x2 <> y2) (x3 y3)+ -}+ instance $(contextT 1 ''Monoid) => Applicative $(strictTupleUnsatT 1)+ where+ pure = $(foldl' appE (conE $ strictDName ?n) $+ replicate (?n - 1) [| mempty |])+ $(strictTupleP xs) <*> $(strictTupleP ys) =+ $(foldl' appE (conE $ strictDName ?n) $+ let sappendE's = init $ zipWith sappendE xs ys+ in sappendE's ++ [varE (last xs) `appE` varE (last ys)]) - {-- instance Swap (StrictTuple3 a) where- swap (StrictTuple3 x0 x1 x2) = StrictTuple3 x0 x2 x1- -}- instance Swap $(strictTupleUnsatT 2) where- swap $(strictTupleP xs) =- $(strictTupleUnsatE 2) $(varE x2) $(varE x1)+ {-+ instance (Monoid a, Monoid b) => Monad (StrictTuple3 a b) where+ StrictTuple3 x1 x2 x3 >>= f = StrictTuple3 (x1 <> y1) (x2 <> y2) y3+ where+ StrictTuple3 y1 y2 y3 = f x3+ -}+ instance $(contextT 1 ''Monoid) => Monad $(strictTupleUnsatT 1) where+ $(strictTupleP xs) >>= f = $(foldl' appE (conE $ strictDName ?n) $+ init (zipWith sappendE xs ys) ++ [varE $ last ys])+ where+ $(strictTupleP ys) = f $(varE $ last xs) - {-- instance Bifoldable (StrictTuple3 a) where- bifoldMap f g ~(StrictTuple3 _ x1 x2) = f x1 <> g x2- -}- instance Bifoldable $(strictTupleUnsatT 2) where- bifoldMap f g $bifoldMapP = f $(varE x1) <> g $(varE x2)+ {-+ instance (Binary a, Binary b, Binary c) => Binary (StrictTuple3 a b c) where+ put = put . toLazy+ get = toStrict <$> get+ -}+ instance $(contextT 0 ''Binary) => Binary $strictTupleSatT where+ put = put . toLazy+ get = toStrict <$> get - {-- instance Bifunctor (StrictTuple3 a) where- bimap f g ~(StrictTuple3 x0 x1 x2) =- StrictTuple3 x0 (f x1) (g x2)- -}- instance Bifunctor $(strictTupleUnsatT 2) where- bimap f g $(tildeP $ strictTupleP xs) =- $(strictTupleUnsatE 2) (f $(varE x1)) (g $(varE x2))+ {-+ instance (Hashable a, Hashable b, Hashable c) =>+ Hashable (StrictTuple3 a b c)+ -}+ instance $(contextT 0 ''Hashable) => Hashable $strictTupleSatT - {-- instance Bitraversable (StrictTuple3 a) where- bitraverse f g ~(StrictTuple3 x0 x1 x2) =- liftA2 (StrictTuple3 x0) (f x1) (g x2)- -}- instance Bitraversable $(strictTupleUnsatT 2) where- bitraverse f g $(tildeP $ strictTupleP xs) =- $(strictTupleUnsatE 2) <$> f $(varE x1) <*> g $(varE x2)- |]+ {-+ instance (Hashable a, Hashable b) => Hashable1 (StrictTuple3 a b)+ -}+ instance $(contextT 1 ''Hashable) => Hashable1 $(strictTupleUnsatT 1) - return $ strictTupleDef- : hashableInst- : hashable1Inst- : eq1Inst- : eq2Inst- : nfDataInst- : nfData1Inst- : nfData2Inst- : binaryInst- : applicativeInst- : monadInst- : otherInsts+ {-+ instance (Hashable a) => Hashable2 (StrictTuple3 a) where+ liftHashWithSalt2 f g s (StrictTuple3 x1 x2 x3) =+ (s `hashWithSalt` x1) `f` x2 `g` x3+ -}+ instance $(contextT 2 ''Hashable) =>+ Hashable2 $(strictTupleUnsatT 2) where+ liftHashWithSalt2 f g s $(strictTupleP xs) = $(+ let accHashE acc x = [| $(acc) `hashWithSalt` $(varE x) |]+ in parensE $ foldl' accHashE [| s |] $ dropLast 2 xs)+ `f` $(varE x1)+ `g` $(varE x2)++ {-+ instance Strict (a, b, c) (StrictTuple3 a b c) where+ toStrict (x1, x2, x3) = StrictTuple3 x1 x2 x3+ toLazy (StrictTuple3 x1 x2 x3) = (x1, x2, x3)+ -}+ instance Strict $lazyTupleSatT $strictTupleSatT where+ toStrict $(tupP $ map varP xs) = $strictTupleSatE+ toLazy $(strictTupleP xs) = $(tupE $ map varE xs)++#if !defined(LENS)+ {-+ instance Lens.Micro.Strict (a, b, c) (StrictTuple3 a b c) where+ strict = lens toStrict (const toLazy)+ lazy = lens toLazy (const toStrict)+ -}+ instance Lens.Micro.Strict $lazyTupleSatT $strictTupleSatT where+ strict f = fmap toLazy . f . toStrict+ {-# INLINE strict #-}+ lazy f = fmap toStrict . f . toLazy+ {-# INLINE lazy #-}+#endif++ {-+ instance Swap (StrictTuple3 a) where+ swap (StrictTuple3 x1 x2 x3) = StrictTuple3 x1 x3 x2+ -}+ instance Swap $(strictTupleUnsatT 2) where+ swap $(strictTupleP xs) =+ $(strictTupleUnsatE 2) $(varE x2) $(varE x1)++ {-+ instance Bifoldable (StrictTuple3 a) where+ bifoldMap f g ~(StrictTuple3 _ x1 x2) = f x1 <> g x2+ -}+ instance Bifoldable $(strictTupleUnsatT 2) where+ bifoldMap f g $(tildeP $ conP (strictDName ?n) $+ replicate (?n - 2) wildP ++ [varP x1, varP x2])+ = f $(varE x1) <> g $(varE x2)++ {-+ instance Bifunctor (StrictTuple3 a) where+ bimap f g ~(StrictTuple3 x1 x2 x3) = StrictTuple3 x1 (f x2) (g x3)+ -}+ instance Bifunctor $(strictTupleUnsatT 2) where+ bimap f g $(tildeP $ strictTupleP xs) =+ $(strictTupleUnsatE 2) (f $(varE x1)) (g $(varE x2))++ {-+ instance Bitraversable (StrictTuple3 a) where+ bitraverse f g ~(StrictTuple3 x1 x2 x3) =+ liftA2 (StrictTuple3 x1) (f x2) (g x3)+ -}+ instance Bitraversable $(strictTupleUnsatT 2) where+ bitraverse f g $(tildeP $ strictTupleP xs) =+ $(strictTupleUnsatE 2) <$> f $(varE x1) <*> g $(varE x2)++ {-+ instance Each (StrictTuple3 a a a) (StrictTuple3 b b b) a b where+ each f ~(StrictTuple3 x1 x2 x3) =+ StrictTuple3 <$> f x1 <*> f x2 <*> f x3+ -}+ instance Each+ $(strictTupleAllSameT aT)+ $(strictTupleAllSameT bT)+ $aT+ $bT+ where+ each f $(tildeP $ strictTupleP xs) =+ $(applicativeE [[| f $(varE x) |] | x <- xs])+ {-# INLINE each #-}+ |]++ return $ strictTupleDef : fieldNInsts ++ otherInsts
test/DocTest01.hs view
@@ -1,9 +1,15 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} module DocTest01 (main) where -import Data.Tuple.Classes (curryN', uncurryN')+import Data.Tuple.Classes (uncurriedN')+#if defined(LENS)+import Control.Lens (over)+#else+import Lens.Micro (over)+#endif -- Function wrapper that expects a unary function printArgAndRun :: (Show a) => (a -> IO b) -> a -> IO b@@ -17,10 +23,9 @@ putStrLn title print $ i + j --- We can adapt them+-- We can adapt it printArgsTitleAndSum :: String -> Int -> Int -> IO ()-printArgsTitleAndSum =- curryN' @3 $ printArgAndRun $ uncurryN' @3 printTitleAndSum+printArgsTitleAndSum = over (uncurriedN' @3) printArgAndRun printTitleAndSum main :: IO () main = printArgsTitleAndSum "Important identity" 26885 15184
test/DocTest02.hs view
@@ -8,6 +8,7 @@ consTuple :: (TupleAt 1 a t u) => a -> t -> u consTuple = tupleInsert @1+infixr `consTuple` main :: IO ()-main = print $ consTuple 'x' $ consTuple False ("sequitur", "quodlibet")+main = print $ 'x' `consTuple` False `consTuple` ("sequitur", "quodlibet")
test/Spec.hs view
@@ -1,10 +1,18 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GHC2021 #-} module Main (main) where -import Control.Exception (SomeException, catch, evaluate)+import Control.Exception (SomeException, catch, evaluate)+import Data.Functor.Classes import Data.Tuple.Classes+import Text.Read (readPrec_to_S)+#if defined(LENS)+import Control.Lens+#else+import Lens.Micro+#endif import DocTest01 qualified import DocTest02 qualified@@ -16,6 +24,9 @@ testUncurryNLaziness testTupleInsertLaziness+ testFieldN+ testShow2+ testRead2 testUncurryNLaziness :: IO () testUncurryNLaziness = do@@ -37,3 +48,28 @@ strictConverged <- test $ ith @2 $ tupleInsert @2 () (undefined :: Identity Int) if strictConverged then error "not strict enough" else putStrLn "OK"++testFieldN :: IO ()+testFieldN = putStrLn $ StrictTuple5 () () () () "OK" ^. _5++nestedS :: String+nestedS = "StrictTuple3 (StrictTuple3 1 2 3) 2 3"++nested :: StrictTuple3 (StrictTuple3 Int Int Int) Int Int+nested = StrictTuple3 (StrictTuple3 1 2 3) 2 3++testShow2 :: IO ()+testShow2 = do+ let expected = nestedS+ got = showsPrec2 0 nested ""+ if expected == got+ then putStrLn "OK"+ else error $ "expected " ++ show expected ++ "; got " ++ show got++testRead2 :: IO ()+testRead2 = do+ let expected = [(nested, "")]+ got = readPrec_to_S readPrec2 0 nestedS+ if expected == got+ then putStrLn "OK"+ else error $ "expected " ++ show expected ++ "; got " ++ show got
tuple-classes.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: tuple-classes-version: 1.0.1+version: 1.0.2 synopsis: Working with n-ary tuples and functions; strict tuples description: Please see the README on Codeberg at <https://codeberg.org/sjshuck/tuple-classes#readme> category: data@@ -25,6 +25,11 @@ type: git location: https://codeberg.org/sjshuck/tuple-classes +flag lens+ description: Use the full lens library instead of microlens.+ manual: False+ default: False+ library exposed-modules: Data.Tuple.Classes@@ -43,6 +48,13 @@ , strict , template-haskell default-language: GHC2021+ if flag(lens)+ cpp-options: -DLENS+ build-depends:+ lens+ else+ build-depends:+ microlens test-suite tuple-classes-test type: exitcode-stdio-1.0@@ -64,3 +76,10 @@ , template-haskell , tuple-classes default-language: Haskell2010+ if flag(lens)+ cpp-options: -DLENS+ build-depends:+ lens+ else+ build-depends:+ microlens