data-diverse-lens 1.0.0.1 → 2.0.0.0

raw patch · 8 files changed

+310/−213 lines, 8 filesdep ~data-diversePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: data-diverse

API changes (from Hackage documentation)

Files

• README.md +5/−0
• data-diverse-lens.cabal +3/−3
• src/Data/Diverse/Lens/Many.hs +74/−82
• src/Data/Diverse/Lens/Which.hs +91/−34
• src/Data/Diverse/Profunctor.hs +5/−0
• src/Data/Diverse/Profunctor/Many.hs +54/−37
• src/Data/Diverse/Profunctor/Which.hs +68/−56
• test/Data/Diverse/Lens/WhichSpec.hs +10/−1

@@ -8,6 +8,11 @@  # Changelog +* 2.0.0.0+  - Breaking change: Removed HasProject and AsInject typeclasses and changed them back to functions.+  - Added 'MatchingFacet' typeclasses for polymorphic 'matching' of prisms.+  - Added constraint synonyms for Project/Inject/Projected/Injected.+ * 1.0.0.1   - Fixed missing exports of the new lens classes. 

@@ -1,5 +1,5 @@ name:                data-diverse-lens-version:             1.0.0.1+version:             2.0.0.0 synopsis:            Isos & Lens for Data.Diverse.Many and Prisms for Data.Diverse.Which description:         Isos & Lens for Data.Diverse.Many and Prisms for Data.Diverse.Which                      Refer to [ManySpec.hs](https://github.com/louispan/data-diverse-lens/blob/master/test/Data/Diverse/Lens/ManySpec.hs) and [WhichSpec.hs](https://github.com/louispan/data-diverse-lens/blob/master/test/Data/Diverse/Lens/WhichSpec.hs) for example usages.@@ -24,7 +24,7 @@                        Data.Diverse.Profunctor.Many                        Data.Diverse.Profunctor.Which   build-depends:       base >= 4.7 && < 5-                     , data-diverse >= 2.0.0.0+                     , data-diverse >= 2.0.1.0                      , tagged >= 0.8.5                      , profunctors >= 5.2                      , generic-lens >= 0.5.0.0@@ -39,7 +39,7 @@   other-modules:       Data.Diverse.Lens.ManySpec                        Data.Diverse.Lens.WhichSpec   build-depends:       base-                     , data-diverse >= 2.0.0.0+                     , data-diverse >= 2.0.1.0                      , data-diverse-lens                      , hspec >= 2                      , lens >= 4

@@ -1,15 +1,17 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}  module Data.Diverse.Lens.Many (@@ -31,12 +33,18 @@      -- * Multiple fields     -- ** Lens for multiple fields-    , HasProject(..)-    , HasProject'(..)-    , HasProjectL(..)-    , HasProjectL'(..)-    , HasProjectN(..)-    , HasProjectN'(..)+    , Project+    , project+    , Project'+    , project'+    , ProjectL+    , projectL+    , ProjectL'+    , projectL'+    , ProjectN+    , projectN+    , ProjectN'+    , projectN'     ) where  import Control.Lens@@ -44,6 +52,7 @@ import Data.Diverse.Many import Data.Diverse.TypeLevel import Data.Generics.Product+import Data.Kind import GHC.TypeLits  -- | @_Many = iso fromMany toMany@@@ -84,8 +93,8 @@ -- -- @ -- let x = (5 :: Int) './' Tagged \@Foo False './' Tagged \@Bar \'X' './' 'nil'--- x '^.' 'itemL'' \@Foo Proxy \`shouldBe` Tagged \@Foo False--- (x '&' 'itemL'' \@Foo Proxy '.~' Tagged \@Foo True) \`shouldBe` (5 :: Int) './' Tagged \@Foo True './' Tagged \@Bar \'X' './' 'nil'+-- x '^.' 'itemL'' \@Foo \`shouldBe` Tagged \@Foo False+-- (x '&' 'itemL'' \@Foo '.~' Tagged \@Foo True) \`shouldBe` (5 :: Int) './' Tagged \@Foo True './' Tagged \@Bar \'X' './' 'nil' -- @ class HasItemL' (l :: k) a s | s l -> a where     itemL' :: Lens' s a@@ -97,7 +106,7 @@ -- -- @ -- let x = (5 :: Int) './' Tagged @Foo False './' Tagged \@Bar \'X' './' 'nil'--- (x '&' 'itemL' \@Foo Proxy '.~' \"foo") \`shouldBe` (5 :: Int) './' \"foo" './' Tagged \@Bar \'X' './' 'nil'+-- (x '&' 'itemL' \@Foo '.~' \"foo") \`shouldBe` (5 :: Int) './' \"foo" './' Tagged \@Bar \'X' './' 'nil' -- @ class HasItemL (l :: k) a b s t | s l -> a, t l -> b, s l b -> t, t l a -> s where     itemL :: Lens s t a b@@ -137,8 +146,8 @@ -- -- @ -- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' ./ nil--- x '^.' 'itemN'' (Proxy \@0) \`shouldBe` 5--- (x '&' 'itemN'' (Proxy @0) '.~' 6) \`shouldBe` (6 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nil'+-- x '^.' 'itemN'' \@0 \`shouldBe` 5+-- (x '&' 'itemN'' \@0 '.~' 6) \`shouldBe` (6 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nil' -- @ class HasItemN' (n :: Nat) a s | s n -> a where     itemN' :: Lens' s a@@ -160,8 +169,8 @@  ----------------------------------------------------------------------- --- type family Projected (xs :: k) s--- type instance Projected xs (Many _) = Many xs+-- | A friendlier constraint synonym for 'project''.+type Project' (smaller :: [Type]) (larger :: [Type]) = (Select smaller larger, Amend' smaller larger)  -- | 'select' ('view' 'project') and 'amend' ('set' 'project') in 'Lens'' form. --@@ -171,77 +180,69 @@ -- -- @ -- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nil'--- x '^.' ('project'' \@'[Int, Maybe Char]) \`shouldBe` (5 :: Int) './' Just \'O' './' 'nil'--- (x '&' ('project'' \@'[Int, Maybe Char]) '.~' ((6 :: Int) './' Just 'P' './' 'nil')) \`shouldBe`+-- x '^.' ('project'' \@_ \@'[Int, Maybe Char]) \`shouldBe` (5 :: Int) './' Just \'O' './' 'nil'+-- (x '&' ('project'' \@_ \@'[Int, Maybe Char]) '.~' ((6 :: Int) './' Just 'P' './' 'nil')) \`shouldBe` --     (6 :: Int) './' False './' \'X' './' Just \'P' './' 'nil' -- @-class HasProject' (as :: k) (ss :: k) a s | a -> as, s -> ss, s as -> a, a ss -> s where-    project' :: Lens' s a--    -- | Make it easy to create an instance of 'project' using 'Data.Generics.Product.Subtype'-    default project' :: (Subtype a s) => Lens' s a-    project' = super+project' :: forall smaller larger. Project' smaller larger => Lens' (Many larger) (Many smaller)+project' = lens select amend' -instance (Select smaller larger, Amend' smaller larger)-  => HasProject' smaller larger (Many smaller) (Many larger) where-    project' = lens select amend'+-- | A friendlier constraint synonym for 'project'.+type Project (smaller :: [Type]) (smaller' :: [Type]) (larger :: [Type]) (larger' :: [Type]) =+    ( Select smaller larger+    , Amend smaller smaller' larger+    , larger' ~ Replaces smaller smaller' larger+    )  -- | Polymorphic version of project'-class HasProject (as :: k) (bs :: k) (ss :: k) (ts :: k) a b s t-        | a -> as, b -> bs, s -> ss, t -> ts-        , b as -> a, s as -> a, t as -> a-        , a bs -> b, s bs -> b, t bs -> b-        , a ss -> s, b ss -> s, t ss -> s-        , a ts -> t, b ts -> t, s ts -> t-        , s a b -> t, t a b -> s where-    project :: Lens s t a b+project :: forall smaller smaller' larger larger'. Project smaller smaller' larger larger'+    => Lens (Many larger) (Many larger') (Many smaller) (Many smaller')+project = lens select (amend @smaller @smaller') -instance (Select smaller larger, Amend smaller smaller' larger, larger' ~ Replaces smaller smaller' larger)-  => HasProject smaller smaller' larger larger' (Many smaller) (Many smaller') (Many larger) (Many larger') where-    project = lens select (amend @smaller @smaller')+-- | A friendlier constraint synonym for 'projectL''.+type ProjectL' (ls :: [k]) (smaller :: [Type]) (larger :: [Type]) =+    ( Select smaller larger+    , Amend' smaller larger+    , smaller ~ KindsAtLabels ls larger+    , IsDistinct ls+    , UniqueLabels ls larger+    )  -- | 'selectL' ('view' 'projectL') and 'amendL' ('set' 'projectL') in 'Lens'' form. -- -- @ -- let x = False './' Tagged \@\"Hi" (5 :: Int) './' Tagged \@Foo False './' Tagged \@Bar \'X' './' Tagged \@\"Bye" \'O' './' 'nil'--- x '^.' ('projectL'' \@'[Foo, Bar] Proxy) \`shouldBe` Tagged \@Foo False './' Tagged \@Bar \'X' './' nil--- (x '&' ('projectL'' \@'[\"Hi", \"Bye"] Proxy) '.~' (Tagged \@\"Hi" (6 :: Int) './' Tagged \@\"Bye" \'P' './' nil)) '`shouldBe`+-- x '^.' ('projectL'' \@'[Foo, Bar] \`shouldBe` Tagged \@Foo False './' Tagged \@Bar \'X' './' nil+-- (x '&' ('projectL'' \@'[\"Hi", \"Bye"] '.~' (Tagged \@\"Hi" (6 :: Int) './' Tagged \@\"Bye" \'P' './' nil)) '`shouldBe` --     False './' Tagged \@\"Hi" (6 :: Int) './' Tagged \@Foo False './' Tagged \@Bar \'X' './' Tagged \@\"Bye" \'P' './' 'nil' -- @-class HasProjectL' (ls :: k1) (as :: k) (ss :: k) a s | a -> as, s -> ss, s as -> a, a ss -> s, s ls -> as where-    projectL' ::  Lens' s a+projectL' :: forall ls smaller larger. ProjectL' ls smaller larger => Lens' (Many larger) (Many smaller)+projectL' = lens (selectL @ls) (amendL' @ls) -instance ( Select smaller larger-         , Amend' smaller larger-         , smaller ~ KindsAtLabels ls larger-         , IsDistinct ls-         , UniqueLabels ls larger) => HasProjectL' ls smaller larger (Many smaller) (Many larger) where-    projectL' = lens (selectL @ls) (amendL' @ls)+-- | A friendlier constraint synonym for 'projectL'.+type ProjectL (ls :: [k]) (smaller :: [Type]) (smaller' :: [Type]) (larger :: [Type]) (larger' :: [Type]) =+    ( Select smaller larger+    , Amend smaller smaller' larger+    , smaller ~ KindsAtLabels ls larger+    , IsDistinct ls+    , UniqueLabels ls larger+    , larger' ~ Replaces smaller smaller' larger+    )  -- | Polymorphic version of 'projectL'' -- -- @ -- let x = False './' Tagged \@\"Hi" (5 :: Int) './' Tagged \@Foo False './' Tagged \@Bar \'X' './' Tagged \@\"Bye" \'O' './' 'nil'--- (x '&' ('projectL' \@'[\"Hi", \"Bye"] Proxy) '.~' (True './' Tagged \@\"Changed" False './' 'nil')) \`shouldBe`+-- (x '&' ('projectL' \@'[\"Hi", \"Bye"] '.~' (True './' Tagged \@\"Changed" False './' 'nil')) \`shouldBe` --     False './' True './' Tagged \@Foo False './' Tagged \@Bar \'X' './' Tagged \@\"Changed" False './' 'nil' -- @-class HasProjectL (ls :: k1) (as :: k) (bs :: k) (ss :: k) (ts :: k) a b s t-        | a -> as, b -> bs, s -> ss, t -> ts-        , b as -> a, s as -> a, t as -> a-        , a bs -> b, s bs -> b, t bs -> b-        , a ss -> s, b ss -> s, t ss -> s-        , a ts -> t, b ts -> t, s ts -> t-        , s ls -> as, t ls -> bs, s ls b -> t, t ls a -> s where-    projectL :: Lens s t a b+projectL :: forall ls smaller smaller' larger larger'. ProjectL ls smaller smaller' larger larger'+  => Lens (Many larger) (Many larger') (Many smaller) (Many smaller')+projectL = lens (selectL @ls) (amendL @ls) -instance ( Select smaller larger-         , Amend smaller smaller' larger-         , smaller ~ KindsAtLabels ls larger-         , IsDistinct ls-         , UniqueLabels ls larger-         , larger' ~ Replaces smaller smaller' larger)-  => HasProjectL ls smaller smaller' larger larger' (Many smaller) (Many smaller') (Many larger) (Many larger') where-    projectL = lens (selectL @ls) (amendL @ls)+-- | A friendlier constraint synonym for 'projectN''.+type ProjectN' (ns :: [Nat]) (smaller :: [Type]) (larger :: [Type]) =+    (SelectN ns smaller larger, AmendN' ns smaller larger)  -- | 'selectN' ('view' 'projectN') and 'amendN' ('set' 'projectN') in 'Lens'' form. --@@ -251,27 +252,18 @@ -- -- @ -- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nil'--- x '^.' ('projectN' \@'[5, 4, 0] Proxy) \`shouldBe` Just \'A' './' (6 :: Int) './' (5 ::Int) './' 'nil'--- (x '&' ('projectN' \@'[5, 4, 0] Proxy) '.~' (Just \'B' './' (8 :: Int) './' (4 ::Int) './' nil)) \`shouldBe`+-- x '^.' 'projectN' \@_ \@'[5, 4, 0] \`shouldBe` Just \'A' './' (6 :: Int) './' (5 ::Int) './' 'nil'+-- (x '&' 'projectN' \@_ \@'[5, 4, 0] '.~' (Just \'B' './' (8 :: Int) './' (4 ::Int) './' nil)) \`shouldBe` --     (4 :: Int) './' False './' \'X' './' Just \'O' './' (8 :: Int) './' Just \'B' './' 'nil' -- @-class HasProjectN' (ns :: [Nat]) (as :: k) (ss :: k) a s | a -> as, s -> ss, s as -> a, a ss -> s, s ns -> as where-    projectN' :: Lens' s a+projectN' :: forall ns smaller larger. ProjectN' ns smaller larger => Lens' (Many larger) (Many smaller)+projectN' = lens (selectN @ns) (amendN' @ns) -instance (SelectN ns smaller larger, AmendN' ns smaller larger)-  => HasProjectN' ns smaller larger (Many smaller) (Many larger) where-    projectN' = lens (selectN @ns) (amendN' @ns)+-- | A friendlier constraint synonym for 'projectN'.+type ProjectN (ns :: [Nat]) (smaller :: [Type]) (smaller' :: [Type]) (larger :: [Type]) (larger' :: [Type]) =+    (SelectN ns smaller larger, AmendN ns smaller smaller' larger, larger' ~ ReplacesIndex ns smaller' larger)  -- | Polymorphic version of 'projectN''-class HasProjectN (ns :: [Nat]) (as :: k) (bs :: k) (ss :: k) (ts :: k) a b s t-        | a -> as, b -> bs, s -> ss, t -> ts-        , b as -> a, s as -> a, t as -> a-        , a bs -> b, s bs -> b, t bs -> b-        , a ss -> s, b ss -> s, t ss -> s-        , a ts -> t, b ts -> t, s ts -> t-        , s ns -> as, t ns -> bs, s ns b -> t, t ns a -> s where-    projectN :: Lens s t a b--instance (SelectN ns smaller larger, AmendN ns smaller smaller' larger, larger' ~ ReplacesIndex ns smaller' larger)-  => HasProjectN ns smaller smaller' larger larger' (Many smaller) (Many smaller') (Many larger) (Many larger') where-    projectN = lens (selectN @ns) (amendN @ns)+projectN :: forall ns smaller smaller' larger larger'. ProjectN ns smaller smaller' larger larger'+    => Lens (Many larger) (Many larger') (Many smaller) (Many smaller')+projectN = lens (selectN @ns) (amendN @ns)

@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-}@@ -16,22 +17,32 @@       -- * Single type       -- ** Prism       AsFacet(..)+    , MatchingFacet(..)     , AsFacetL(..)+    , MatchingFacetL(..)     , AsFacetTag(..)+    , MatchingFacetTag(..)     -- , genericFacetTag     , AsFacetN(..)+    , MatchingFacetN(..)        -- * Multiple types       -- ** Prism-    , AsInject(..)-    , AsInjectL(..)-    , AsInjectN(..)+    , Inject+    , inject+    -- , MatchingInject(..)+    , InjectL+    , injectL+    -- , MatchingInjectL(..)+    , InjectN+    , injectN     ) where  import Control.Lens import Data.Diverse.Which import Data.Diverse.TypeLevel import Data.Generics.Sum+import Data.Kind import Data.Tagged import GHC.TypeLits @@ -58,11 +69,30 @@ instance UniqueMember x xs => AsFacet x (Which xs) where     facet = prism' pick trial' +class AsFacet a s => MatchingFacet a s t | s a -> t where+    -- | Unfortunately, polymorphic @Prism s t a b@ cannot be used as it can only be created with:+    -- @+    -- (UniqueMember x xs, UniqueMember y ys, ys ~ Remove x xs)+    -- => prism (pick :: y -> Which ys) (trial :: Which xs -> Either (Which ys) x)+    -- @+    -- This above causes problems when used monomorphically with @s ~ t@ and @x ~ y@ since+    -- @xs@ cannot equal @ys ~ Remove x x@.+    --+    -- What is desirec is:+    -- (UniqueMember x xs, ys ~ Remove x xs)+    -- => prism_ (pick :: x -> Which xs) (trial :: Which xs -> Either (Which ys) x)+    --+    -- So we expose the polymorhpic 'matching' explicitly.+    matchingFacet :: s -> Either t a++instance (UniqueMember x xs, ys ~ Remove x xs) => MatchingFacet x (Which xs) (Which ys) where+    matchingFacet = trial+ -- | 'pickL' ('review' 'facetL') and 'trialL'' ('preview' 'facetL'') in 'Prism'' form. -- -- @--- let y = 'review' ('facetL' \@Bar Proxy) (Tagged (5 :: Int)) :: Which '[Tagged Foo Bool, Tagged Bar Int, Char, Bool, Char]---     x = 'preview' ('facetL' \@Bar Proxy) y+-- let y = 'review' 'facetL' \@Bar (Tagged (5 :: Int)) :: Which '[Tagged Foo Bool, Tagged Bar Int, Char, Bool, Char]+--     x = 'preview' 'facetL' \@Bar y -- x \`shouldBe` (Just (Tagged 5)) -- @ class AsFacetL (l :: k) a s | s l -> a where@@ -71,6 +101,14 @@ instance (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => AsFacetL l x (Which xs) where     facetL = prism' (pickL @l) (trialL' @l) +-- | Labelled version of 'MatchingFacet'+class AsFacetL l a s => MatchingFacetL l a s t | s a -> t where+    matchingFacetL :: s -> Either t a++instance (UniqueLabelMember l xs, x ~ KindAtLabel l xs, ys ~ Remove x xs)+  => MatchingFacetL l x (Which xs) (Which ys) where+    matchingFacetL = trialL @l+ -- | Variation of 'fetchL' specialized to 'Tagged' which automatically tags and untags the field. -- A default implementation using generics is not provided as it make GHC think that @l@ must be type @Symbol@ -- when @l@ can actually be any kind.@@ -90,6 +128,14 @@ instance (UniqueLabelMember l xs, Tagged l x ~ KindAtLabel l xs) => AsFacetTag l x (Which xs) where     facetTag = prism' (pickTag @l) (trialTag' @l) +-- | Untagged version of 'MatchingFacet'+class AsFacetTag l a s => MatchingFacetTag l a s t | l s a -> t where+    matchingFacetTag :: s -> Either t a++instance (UniqueLabelMember l xs, Tagged l x ~ KindAtLabel l xs, ys ~ Remove (Tagged l x) xs)+  => MatchingFacetTag l x (Which xs) (Which ys) where+    matchingFacetTag = trialTag @l+ -- | 'pickN' ('review' 'facetN') and 'trialN' ('preview' 'facetN') in 'Prism'' form. -- -- @@@ -97,8 +143,8 @@ -- @ -- -- @--- let y = 'review' ('facetN' (Proxy \@4)) (5 :: Int) :: 'Which' '[Bool, Int, Char, Bool, Int, Char] -- 'pickN'---     x = 'preview' ('facetN' (Proxy \@4)) y -- 'trialN'+-- let y = 'review' ('facetN' \@4) (5 :: Int) :: 'Which' '[Bool, Int, Char, Bool, Int, Char] -- 'pickN'+--     x = 'preview' ('facetN' \@4) y -- 'trialN' -- x \`shouldBe` (Just 5) -- @ class AsFacetN (n :: Nat) a s | s n -> a where@@ -107,59 +153,70 @@ instance (MemberAt n x xs) => AsFacetN n x (Which xs) where     facetN = prism' (pickN @n) (trialN' @n) +-- | Nat indexed version of 'MatchingFacet'+class AsFacetN n a s => MatchingFacetN n a s t | s a -> t where+    matchingFacetN :: s -> Either t a++instance (MemberAt n x xs, ys ~ RemoveIndex n xs)+  => MatchingFacetN n x (Which xs) (Which ys) where+    matchingFacetN = trialN @n+ ------------------------------------------------------------------ +-- | A friendlier constraint synonym for 'inject'+type Inject (branch :: [Type]) (tree :: [Type]) = ( Diversify branch tree+                                                  , Reinterpret' branch tree+                                                  )+ -- | 'diversify' ('review' 'inject') and 'reinterpret'' ('preview' 'inject') in 'Prism'' form. -- -- @ -- let x = 'pick' (5 :: Int) :: 'Which' '[String, Int]---     y = 'review' ('inject' \@_ \@[Bool, Int, Char, String]) x -- 'diversify'+--     y = 'review' ('inject' \@_  @_ \@[Bool, Int, Char, String]) x -- 'diversify' -- y \`shouldBe` pick (5 :: Int) :: 'Which' '[Bool, Int, Char, String]--- let y' = 'preview' ('inject' \@[String, Int]) y -- 'reinterpret'+-- let y' = 'preview' ('inject' \@_ \@[String, Int]) y -- 'reinterpret' -- y' \`shouldBe` Just (pick (5 :: Int)) :: Maybe ('Which' '[String, Int]) -- @-class AsInject (as :: k) (ss :: k) a s | a -> as, s -> ss, s as -> a, a ss -> s where-    inject :: Prism' s a+inject :: forall branch tree. (Inject branch tree) => Prism' (Which tree) (Which branch)+inject = prism' diversify reinterpret' -instance ( Diversify branch tree-         , Reinterpret' branch tree-         ) => AsInject branch tree (Which branch) (Which tree) where-    inject = prism' diversify reinterpret'+-- | A friendlier constraint synonym for 'injectL'+type InjectL (ls :: [k]) (branch :: [Type]) (tree :: [Type]) =+    ( Diversify branch tree+    , Reinterpret' branch tree+    , branch ~ KindsAtLabels ls tree+    , UniqueLabels ls tree+    , IsDistinct ls+    )  -- | 'diversifyL' ('review' 'injectL') and 'reinterpretL'' ('preview' 'injectL') in 'Prism'' form. -- -- @ -- let t = 'pick' \@[Tagged Bar Int, Tagged Foo Bool, Tagged Hi Char, Tagged Bye Bool] (5 :: Tagged Bar Int) --     b = 'pick' \@'[Tagged Foo Bool, Tagged Bar Int] (5 :: Tagged Bar Int)---     t' = 'review' ('injectL' \@[Foo, Bar] \@_ \@[Tagged Bar Int, Tagged Foo Bool, Tagged Hi Char, Tagged Bye Bool] Proxy) b---     b' = 'preview' ('injectL' \@[Foo, Bar] Proxy) t'+--     t' = 'review' ('injectL' \@_ \@[Foo, Bar] \@_ \@[Tagged Bar Int, Tagged Foo Bool, Tagged Hi Char, Tagged Bye Bool]) b+--     b' = 'preview' ('injectL' \@_ \@[Foo, Bar]) t' -- t \`shouldBe` t' -- b' \`shouldBe` Just b -- @-class AsInjectL (ls :: k1) (as :: k) (ss :: k) a s | a -> as, s -> ss, s as -> a, a ss -> s, s ls -> as where-    injectL :: Prism' s a+injectL :: forall ls branch tree. InjectL ls branch tree => Prism' (Which tree) (Which branch)+injectL = prism' (diversifyL @ls) (reinterpretL' @ls) -instance ( Diversify branch tree-         , Reinterpret' branch tree-         , branch ~ KindsAtLabels ls tree-         , UniqueLabels ls tree-         , IsDistinct ls-         ) => AsInjectL ls branch tree (Which branch) (Which tree) where-    injectL = prism' (diversifyL @ls) (reinterpretL' @ls)+-- | A friendlier constraint synonym for 'injectN'+type InjectN (ns :: [Nat]) (branch :: [Type]) (tree :: [Type]) =+    ( DiversifyN ns branch tree+    , ReinterpretN' ns branch tree+    )  -- | 'diversifyN' ('review' 'injectN') and 'reinterpretN'' ('preview' 'injectN') in 'Prism'' form. -- -- @ -- let x = 'pick' (5 :: Int) :: 'Which' '[String, Int]---     y = 'review' (injectN \@[3, 1] \@_ \@[Bool, Int, Char, String] Proxy) x -- 'diversifyN'+--     y = 'review' (injectN \@_ \@[3, 1] \@_ \@[Bool, Int, Char, String]) x -- 'diversifyN' -- y \`shouldBe` pick (5 :: Int) :: 'Which' '[Bool, Int, Char, String]--- let y' = 'preview' ('injectN' @[3, 1] \@[String, Int] Proxy) y -- 'reinterpertN''+-- let y' = 'preview' ('injectN' \@_ @[3, 1] \@[String, Int]) y -- 'reinterpertN'' -- y' \`shouldBe` Just ('pick' (5 :: Int)) :: Maybe ('Which' '[String, Int]) -- @-class AsInjectN (ns :: [Nat]) (as :: k) (ss :: k) a s | a -> as, s -> ss, s as -> a, a ss -> s, s ns -> as where-    injectN :: Prism' s a -instance ( DiversifyN ns branch tree-       , ReinterpretN' ns branch tree-       ) => AsInjectN ns branch tree (Which branch) (Which tree) where-    injectN = prism' (diversifyN @ns) (reinterpretN' @ns)+injectN :: forall ns branch tree. InjectN ns branch tree => Prism' (Which tree) (Which branch)+injectN = prism' (diversifyN @ns) (reinterpretN' @ns)

@@ -1,11 +1,16 @@ module Data.Diverse.Profunctor (     -- * Re-export "Data.Diverse" for convenience       module Data.Diverse+    -- * Iso's, Lens and Prisms for 'Data.Diverse.Many.Many' and 'Data.Diverse.Which.Which'+    , module Data.Diverse.Lens.Many+    , module Data.Diverse.Lens.Which     -- * Combinators analogous to Profunctor Strong and Choice     , module Data.Diverse.Profunctor.Many     , module Data.Diverse.Profunctor.Which     ) where  import Data.Diverse+import Data.Diverse.Lens.Many+import Data.Diverse.Lens.Which import Data.Diverse.Profunctor.Many import Data.Diverse.Profunctor.Which

@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}@@ -21,79 +22,95 @@ import Control.Arrow import Control.Lens import Data.Diverse.Many+import Data.Diverse.Lens.Many import Data.Diverse.TypeLevel import Data.Profunctor +-- | A friendlier constraint synonym for 'itemized'.+type Itemized w a b s t =+    ( Profunctor w+    , Strong w+    , HasItem a b s t+    , HasItem' a s+    )+ -- | Like 'Strong' or 'Arrow' but lifting into 'Many' itemized-    :: forall a' w a b. ( Profunctor w-       , Strong w-       , UniqueMember a a'-       , UniqueMember b (Replace a b a')-       )-    => w a b -> w (Many a') (Many (Replace a b a'))-itemized w = dimap (\c -> (fetch c, c)) (\(b, c) -> replace @a c b) (first' w)+    :: forall w a b s t. (Itemized w a b s t)+    => w a b -> w s t+itemized w = dimap (\c -> (view item' c, c)) (\(b, c) -> set (item @a) b c) (first' w)  -- | Like 'Strong' or 'Arrow' but lifting into 'Many' of one type itemized' :: Profunctor w => w a b -> w (Many '[a]) (Many '[b]) itemized' w = dimap fetch single w +-- | A friendlier constraint synonym for 'projected'.+type Projected w a1 a2 b1 b2 =+    ( Profunctor w+    , Strong w+    , Select a1 a2+    , Amend a1 b1 a2+    , b2 ~ Replaces a1 b1 a2+    )+ -- | Like 'Strong' or 'Arrow' but lifting from a 'Many' to a 'Many' of another type projected-    :: forall a' proxy w a b. ( Profunctor w-       , Strong w-       , Select a a'-       , Amend a b a'-       )-    => proxy a' -> w (Many a) (Many b) -> w (Many a') (Many (Replaces a b a'))-projected _ w = dimap (\c -> (select c, c)) (\(b, c) -> amend @a c b) (first' w)+    :: forall proxy w a1 a2 b1 b2. (Projected w a1 a2 b1 b2)+    => proxy a2 -> w (Many a1) (Many b1) -> w (Many a2) (Many b2)+projected _ w = dimap (\c -> (select c, c)) (\(b, c) -> amend @a1 c b) (first' w) +-- | A friendlier constraint synonym for '*&&*'.+type SelectWith w a1 a2 a3 b1 b2 b3 =+    ( C.Category w+    , Profunctor w+    , Strong w+    , Select a1 (AppendUnique a1 a2)+    , Select a2 (AppendUnique a1 a2)+    , a3 ~ AppendUnique a1 a2+    , b3 ~ Append b1 b2+    )+ -- | Split the input between the two argument arrows and combine their output. -- The type of the resultant input is a 'Many' of all the unique types in the argument arrows' inputs, -- The type of the resultant output is a concatenated 'Many' of the arguments arrows' outputs. -- Analogous to a 'Many' combination of both of 'Control.Arrow.***' and 'Control.Arrow.&&&'. -- It is a compile error if the types are not distinct in each of the argument arrow inputs. (*&&*)-    :: forall w a1 b1 a2 b2. ( C.Category w-       , Profunctor w-       , Strong w-       , Select a1 (AppendUnique a1 a2)-       , Select a2 (AppendUnique a1 a2)-       )+    :: forall w a1 a2 a3 b1 b2 b3. (SelectWith w a1 a2 a3 b1 b2 b3)     => w (Many a1) (Many b1)     -> w (Many a2) (Many b2)-    -> w (Many (AppendUnique a1 a2)) (Many (Append b1 b2))+    -> w (Many a3) (Many b3) x *&&* y = rmap (uncurry (/./)) (lmap (select @a1 &&& select @a2) (first' x) C.>>> second' y) infixr 3 *&&* -- like *** --- | Left-to-right chaining of arrows one after another,  where left over input not consumed+-- | A friendlier constraint synonym for '>&&>'.+type ThenSelect w a2 b1 b2 b3 =+    ( C.Category w+    , Profunctor w+    , Strong w+    , Select (Complement b1 a2) b1+    , Select a2 b1+    , b3 ~ Append (Complement b1 a2) b2+    )++-- | Left-to-right chaining of arrows one after another, where left over input not consumed -- by the right arrow is forwarded to the output. -- It is a compile error if the types are not distinct in each of the argument arrow inputs, -- or if the input of the second arrow is not a subset of the output of the first arrow. (>&&>)-    :: forall w a b1 a2 b2.-       ( C.Category w-       , Profunctor w-       , Strong w-       , Select (Complement b1 a2) b1-       , Select a2 b1-       )+    :: forall w a a2 b1 b2 b3.+       (ThenSelect w a2 b1 b2 b3)     => w a (Many b1)     -> w (Many a2) (Many b2)-    -> w a (Many (Append (Complement b1 a2) b2))+    -> w a (Many b3) x >&&> y = rmap (uncurry (/./)) (rmap (select @(Complement b1 a2) &&& select @a2) x C.>>> (second' y)) infixr 3 >&&> -- like ***  -- | right-to-left version of '(>&&>)' (<&&<) ::-       ( C.Category w-       , Profunctor w-       , Strong w-       , Select (Complement b1 a2) b1-       , Select a2 b1-       )+       (ThenSelect w a2 b1 b2 b3)     => w (Many a2) (Many b2)     -> w a (Many b1)-    -> w a (Many (Append (Complement b1 a2) b2))+    -> w a (Many b3) (<&&<) = flip (>&&>) infixl 2 <&&< -- like >&&>

@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}@@ -21,41 +22,62 @@ import Control.Lens import Data.Diverse.Which import Data.Diverse.TypeLevel-import Data.Proxy+import Data.Diverse.Lens --- | Like 'Choice' or 'ArrowChoice' but lifting into 'Which'-faceted-    :: ( Profunctor w-       , Choice w-       , UniqueMember a a'-       , UniqueMember b b'-       , Diversify (Complement a' '[a]) b'-       )-    => w a b -> w (Which a') (Which b')-faceted w = dimap trial (either diversify pick) (right' w)+-- | A friendlier constraint synonym for 'faceted'.+type Faceted w a as x b bs y =+    ( Profunctor w+    , Choice w+    , MatchingFacet a x y+    , AsFacet b y+    ) +-- | Like 'Choice' or 'ArrowChoice' but lifting into a polymorphic variant.+faceted :: forall w a as x b bs y.+    Faceted w a as x b bs y => w a b -> w x y+faceted w = dimap (matchingFacet @a @x @y)+                   (either id (review facet))+                   (right' w)+ -- | Like 'Choice' or 'ArrowChoice' but lifting into 'Which' of one type faceted' :: (Profunctor w, Choice w) => w a b -> w (Which '[a]) (Which '[b])-faceted' w = dimap trial (either impossible pick) (right' w)+faceted' w = dimap obvious pickOnly w +-- | A friendlier constraint synonym for 'injected'.+type Injected w a a' b b' =+    ( Profunctor w+    , Choice w+    , Reinterpret a a'+    , Diversify b (AppendUnique (Complement a' a) b)+    , Diversify (Complement a' a) (AppendUnique (Complement a' a) b)+    , b' ~ AppendUnique (Complement a' a) b+    -- extra contraint to prevent surprises (see comment for 'injected')+    , Complement a a' ~ '[]+    )+ -- | Like 'Choice' or 'ArrowChoice' but lifting from 'Which' into another type of 'Which' -- NB. It is a compile error if all of the input types in the second arrow @a@ -- is not the output types of the first arrow. -- This prevents surprising behaviour where the second arrow is ignored. injected-    :: ( Profunctor w-       , Choice w-       , Reinterpret a a'-       , Diversify b (AppendUnique (Complement a' a) b)-       , Diversify (Complement a' a) (AppendUnique (Complement a' a) b)-       -- extra contraint to prevent surprises (see comment above)-       , Complement a a' ~ '[]-       )-    => proxy a'-    -> w (Which a) (Which b)-    -> w (Which a') (Which (AppendUnique (Complement a' a) b))-injected _ w = dimap reinterpret (either diversify diversify) (right' w)+    :: (Injected w a a' b b')+    => w (Which a) (Which b)+    -> w (Which a') (Which b')+injected w = dimap reinterpret (either diversify diversify) (right' w) +-- | A friendlier constraint synonym for '+||+'.+type ChooseBetween w a1 a2 a3 b1 b2 b3 =+    ( C.Category w+    , Profunctor w+    , Choice w+    , Reinterpret a2 (Append a1 a2)+    , a1 ~ Complement (Append a1 a2) a2+    , a3 ~ Append a1 a2+    , Diversify b1 (AppendUnique b1 b2)+    , Diversify b2 (AppendUnique b1 b2)+    , b3 ~ AppendUnique b1 b2+    )+ -- | Split the input between the two argument arrows, retagging and merging their outputs. -- The output is merged into a 'Which' of unique types. -- Analogous to a 'Which' combination of both 'Control.Arrow.+++' and 'Control.Arrow.|||'.@@ -64,24 +86,23 @@ -- The compile error will be due to @(Append a1 a2)@ which will not satisfy -- @UniqueMember@ constraints in 'Reinterpret'. (+||+)-    :: forall w a1 b1 a2 b2.-       ( C.Category w-       , Profunctor w-       , Choice w-       , Reinterpret a2 (Append a1 a2)-       , a1 ~ Complement (Append a1 a2) a2-       , Diversify b1 (AppendUnique b1 b2)-       , Diversify b2 (AppendUnique b1 b2)-       )+    :: forall w a1 a2 a3 b1 b2 b3.+       (ChooseBetween w a1 a2 a3 b1 b2 b3)     => w (Which a1) (Which b1)     -> w (Which a2) (Which b2)-    -> w (Which (Append a1 a2)) (Which (AppendUnique b1 b2))+    -> w (Which a3) (Which b3) x +||+ y =     rmap         (either diversify diversify)         (lmap (reinterpret @a2 @(Append a1 a2)) (left' x) C.>>> right' y) infixr 2 +||+ -- like +++ +-- | A friendlier constraint synonym for '>||>'.+type AlsoChoose w a2 b1 b2 b3 =+    ( C.Category w+    , Injected w a2 b1 b2 b3+    )+ -- | Left-to-right chaining of arrows one after another,  where left over possibilities not handled -- by the right arrow is forwarded to the output. -- It is a compile error if the types are not distinct in each of the argument arrow inputs,@@ -90,31 +111,22 @@ -- This is to prevent surprises behaviour of the second arrow being ignored. -- The compile error will be due to the @Complement c b ~ '[]@ constraint. (>||>)-    :: forall w a b c d.-       ( C.Category w-       , Profunctor w-       , Choice w-       , Reinterpret c b-       , Diversify d (AppendUnique (Complement b c) d)-       , Diversify (Complement b c) (AppendUnique (Complement b c) d)-       , Complement c b ~ '[])-    => w a (Which b)-    -> w (Which c) (Which d)-    -> w a (Which (AppendUnique (Complement b c) d))-(>||>) hdl1 hdl2 = hdl1 C.>>> injected (Proxy @b) hdl2+    :: forall w a a2 b1 b2 b3.+       ( AlsoChoose w a2 b1 b2 b3+       )+    => w a (Which b1)+    -> w (Which a2) (Which b2)+    -> w a (Which b3)+(>||>) hdl1 hdl2 = hdl1 C.>>> injected @_ @_ @b1 hdl2 infixr 2 >||> -- like +||+  -- | right-to-left version of '(>||>)' (<||<)-    :: ( C.Category w-       , Profunctor w-       , Choice w-       , Reinterpret c b-       , Diversify d (AppendUnique (Complement b c) d)-       , Diversify (Complement b c) (AppendUnique (Complement b c) d)-       , Complement c b ~ '[])-    => w (Which c) (Which d)-    -> w a (Which b)-    -> w a (Which (AppendUnique (Complement b c) d))+    :: forall w a a2 b1 b2 b3.+       ( AlsoChoose w a2 b1 b2 b3+       )+    => w (Which a2) (Which b2)+    -> w a (Which b1)+    -> w a (Which b3) (<||<) = flip (>||>) infixl 2 <||< -- like >||>

@@ -5,6 +5,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}  module Data.Diverse.Lens.WhichSpec (main, spec) where @@ -33,10 +34,17 @@     describe "Which" $ do          it "can be constructed and destructed by type with 'facet'" $ do+            -- NB. Int is unique, even if Bool and Char is not unique             let y = review (facet @Int) (5 :: Int) :: Which '[Bool, Int, Char, Bool, Char]                 x = preview (facet @Int) y             x `shouldBe` (Just 5) +        -- it "can be constructed and destructed by type with 'facet'" $ do+        --     -- NB. Int is unique, even if Char is not unique+        --     let y = (view.re') (facet @_ @Int) (5 :: Int) :: Which '[Bool, Int, Char]+        --         x = preview (facet @_ @Int) y+        --     x `shouldBe` (Just 5)+         it "can be constructed and destructed by label with 'facetL'" $ do             let y = review (facetL @Bar) (Tagged (5 :: Int)) :: Which '[Tagged Foo Bool, Tagged Bar Int, Char, Bool, Char]                 x = preview (facetL @Bar) y@@ -65,7 +73,8 @@          it "can be 'diversifyL'ed and 'reinterpretedL' by label with 'injectL'" $ do             let t = pick @_ @[Tagged Bar Int, Tagged Foo Bool, Tagged Hi Char, Tagged Bye Bool] (5 :: Tagged Bar Int)-                b = pick @_ @'[Tagged Foo Bool, Tagged Bar Int] (5 :: Tagged Bar Int)+                b = pick @_ @[Tagged Foo Bool, Tagged Bar Int] (5 :: Tagged Bar Int)+                -- @_ @_ @Which @[Foo, Bar] @[Tagged Bar Int, Tagged Foo Bool, Tagged Hi Char, Tagged Bye Bool]                 t' = review (injectL @[Foo, Bar] @_ @[Tagged Bar Int, Tagged Foo Bool, Tagged Hi Char, Tagged Bye Bool]) b                 b' = preview (injectL @[Foo, Bar]) t'             t `shouldBe` t'