diff --git a/data-diverse.cabal b/data-diverse.cabal --- a/data-diverse.cabal +++ b/data-diverse.cabal @@ -1,5 +1,5 @@ name: data-diverse -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Extensible records and polymorphic variants. description: "Data.Diverse.Many" is an extensible record for any size encoded efficiently as (Int, Map Int Any). "Data.Diverse.Which" is a polymorphic variant of possibilities encoded as (Int, Any). @@ -20,13 +20,11 @@ library hs-source-dirs: src - exposed-modules: Data.Diverse.AFoldable - Data.Diverse + exposed-modules: Data.Diverse + Data.Diverse.AFoldable Data.Diverse.Case Data.Diverse.Cases Data.Diverse.CaseTypeable - Data.Diverse.Collector - Data.Diverse.Emit Data.Diverse.Many Data.Diverse.Many.Internal Data.Diverse.Reduce diff --git a/src/Data/Diverse.hs b/src/Data/Diverse.hs --- a/src/Data/Diverse.hs +++ b/src/Data/Diverse.hs @@ -3,8 +3,6 @@ , module Data.Diverse.Case , module Data.Diverse.Cases , module Data.Diverse.CaseTypeable - , module Data.Diverse.Collector - , module Data.Diverse.Emit , module Data.Diverse.Many , module Data.Diverse.Reduce , module Data.Diverse.Reiterate @@ -16,8 +14,6 @@ import Data.Diverse.Case import Data.Diverse.Cases import Data.Diverse.CaseTypeable -import Data.Diverse.Collector -import Data.Diverse.Emit import Data.Diverse.Many import Data.Diverse.Reduce import Data.Diverse.Reiterate diff --git a/src/Data/Diverse/Case.hs b/src/Data/Diverse/Case.hs --- a/src/Data/Diverse/Case.hs +++ b/src/Data/Diverse/Case.hs @@ -8,8 +8,6 @@ import Data.Diverse.Type import Data.Kind -import GHC.Prim (Any) -import Unsafe.Coerce -- | This class allows defining handlers that can handle the 'Head' type in the @xs@ typelist. -- In conjunction with 'Data.Diverse.Reiterate.Reiterate', you can define handlers that can handle all @@ -19,8 +17,3 @@ class Case c (xs :: [Type]) r where -- | Return the handler/continuation when x is observed. case' :: c xs r -> Head xs -> r - case' c v = caseAny c (unsafeCoerce v) - - -- | A variation of 'case'' where x is left as 'Any' - caseAny :: c xs r -> Any -> r - caseAny c v = case' c (unsafeCoerce v) diff --git a/src/Data/Diverse/Collector.hs b/src/Data/Diverse/Collector.hs deleted file mode 100644 --- a/src/Data/Diverse/Collector.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Data.Diverse.Collector where - -import Data.Diverse.AFoldable -import Data.Diverse.Emit -import Data.Diverse.Reiterate -import Data.Kind -import GHC.TypeLits - --- | Folds output from an 'Emit'ter of values while __'reiterate'__ing the @xs@ typelist. --- This guarantees that the @Emit e '[]@ is not instantiated. --- Undecidable instances! But this is safe since it's a wrapper -newtype Collector e (xs :: [Type]) r = Collector (e xs r) - --- | null case that doesn't even use 'emit', so that an instance of @Emit e '[]@ is not needed. -instance AFoldable (Collector e '[]) r where - afoldr _ z _ = z - --- | Folds values by 'reiterate'ing 'Emit'ters through the @xs@ typelist. -instance ( Emit e (x ': xs) r - , Reiterate e (x ': xs) - , AFoldable (Collector e xs) r - ) => - AFoldable (Collector e (x ': xs)) r where - afoldr f z (Collector e) = f (emit e) (afoldr f z (Collector (reiterate e))) - --- | A variation of 'Collector' which does require the @Emit e '[]@ instance for the empty typelist. --- Undecidable instances! But this is safe since it's a wrapper -newtype Collector0 e (xs :: [Type]) r = Collector0 (e xs r) - --- | terminating case that does use @Emit e '[]@ -instance (Emit e '[] r) => - AFoldable (Collector0 e '[]) r where - afoldr f z (Collector0 e) = f (emit e) z - --- | Folds values by 'reiterate'ing 'Emit'ters through the @xs@ typelist. -instance ( Emit e (x ': xs) r - , Reiterate e (x ': xs) - , AFoldable (Collector0 e xs) r - ) => - AFoldable (Collector0 e (x ': xs)) r where - afoldr f z (Collector0 e) = f (emit e) (afoldr f z (Collector0 (reiterate e))) - --------------------------------------------- - --- | A variation of 'Collector' which __'reiterateN'__s the @xs@ typelist. --- This version guarantees that the @Emit (e n) '[]@ is not instantiated. --- Undecidable instances! But this is safe since it's a wrapper -newtype CollectorN e (n :: Nat) (xs :: [Type]) r = CollectorN (e n xs r) - --- | null case that doesn't even use 'emit', so that an instance of @Emit (e n) '[]@ is not needed. -instance AFoldable (CollectorN e n '[]) r where - afoldr _ z _ = z - --- | Folds values by 'reiterateN'ing 'Emit'ters through the @xs@ typelist. -instance ( Emit (e n) (x ': xs) r - , ReiterateN e n (x ': xs) - , AFoldable (CollectorN e (n + 1) xs) r - ) => - AFoldable (CollectorN e n (x ': xs)) r where - afoldr f z (CollectorN e) = f (emit e) (afoldr f z (CollectorN (reiterateN e))) - --- | A variation of 'Collector0' which __'reiterateN'__s the @xs@ typelist. --- Undecidable instances! But this is safe since it's a wrapper -newtype CollectorN0 e (n :: Nat) (xs :: [Type]) r = CollectorN0 (e n xs r) - --- | terminating case that does use @Emit (e n) '[]@ -instance (Emit (e n) '[] r) => - AFoldable (CollectorN0 e n '[]) r where - afoldr f z (CollectorN0 e) = f (emit e) z - --- | Folds values by 'reiterateN'ing 'Emit'ters through the @xs@ typelist. -instance ( Emit (e n) (x ': xs) r - , ReiterateN e n (x ': xs) - , AFoldable (CollectorN0 e (n + 1) xs) r - ) => - AFoldable (CollectorN0 e n (x ': xs)) r where - afoldr f z (CollectorN0 e) = f (emit e) (afoldr f z (CollectorN0 (reiterateN e))) diff --git a/src/Data/Diverse/Emit.hs b/src/Data/Diverse/Emit.hs deleted file mode 100644 --- a/src/Data/Diverse/Emit.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} - -module Data.Diverse.Emit where - --- | 'Emit' can generate a value, and is differentiated with an additional @xs@ typelist -class Emit e (xs :: [k]) r where - emit :: e xs r -> r diff --git a/src/Data/Diverse/Many.hs b/src/Data/Diverse/Many.hs --- a/src/Data/Diverse/Many.hs +++ b/src/Data/Diverse/Many.hs @@ -11,7 +11,7 @@ , _Many' -- * Construction - , nul + , nil , single , prefix , (./) @@ -29,15 +29,20 @@ -- * Single field -- ** Getter for single field , fetch + , fetchL , fetchN -- ** Setter for single field , replace , replace' + , replaceL + , replaceL' , replaceN , replaceN' -- ** Lens for a single field , item , item' + , itemL + , itemL' , itemN , itemN' @@ -45,6 +50,7 @@ -- ** Getter for multiple fields , Select , select + , selectL , SelectN , selectN -- ** Setter for multiple fields @@ -52,6 +58,8 @@ , amend , Amend' , amend' + , amendL + , amendL' , AmendN , amendN , AmendN' @@ -59,18 +67,16 @@ -- ** Lens for multiple fields , project , project' + , projectL + , projectL' , projectN , projectN' -- * Destruction -- ** By type - , Via -- no constructor - , via -- safe construction , forMany , collect -- ** By Nat index offset - , ViaN -- no constructor - , viaN -- safe construction , forManyN , collectN ) where diff --git a/src/Data/Diverse/Many/Internal.hs b/src/Data/Diverse/Many/Internal.hs --- a/src/Data/Diverse/Many/Internal.hs +++ b/src/Data/Diverse/Many/Internal.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -28,7 +27,7 @@ , _Many' -- * Construction - , nul + , nil , single , prefix , (./) @@ -46,15 +45,20 @@ -- * Single field -- ** Getter for single field , fetch + , fetchL , fetchN -- ** Setter for single field , replace , replace' + , replaceL + , replaceL' , replaceN , replaceN' -- ** Lens for a single field , item , item' + , itemL + , itemL' , itemN , itemN' @@ -62,6 +66,7 @@ -- ** Getter for multiple fields , Select , select + , selectL , SelectN , selectN -- ** Setter for multiple fields @@ -69,6 +74,8 @@ , amend , Amend' , amend' + , amendL + , amendL' , AmendN , amendN , AmendN' @@ -76,18 +83,16 @@ -- ** Lens for multiple fields , project , project' + , projectL + , projectL' , projectN , projectN' -- * Destruction -- ** By type - , Via -- no constructor - , via -- safe construction , forMany , collect -- ** By Nat index offset - , ViaN -- no constructor - , viaN -- safe construction , forManyN , collectN ) where @@ -97,8 +102,6 @@ import Data.Bool import Data.Diverse.AFoldable import Data.Diverse.Case -import Data.Diverse.Collector -import Data.Diverse.Emit import Data.Diverse.Reiterate import Data.Diverse.Type import Data.Kind @@ -118,12 +121,6 @@ -- These usages in this module are safe due to size guarantees provided by the typelist. import Prelude as Partial -newtype Key = Key Int deriving (Eq, Ord, Show) -newtype LeftOffset = LeftOffset Int -newtype LeftSize = LeftSize Int -newtype RightOffset = RightOffset Int -newtype NewRightOffset = NewRightOffset { unNewRightOffset :: Int } - -- | A Many is an anonymous product type (also know as polymorphic record), with no limit on the number of fields. -- -- The following functions are available can be used to manipulate unique fields @@ -151,25 +148,44 @@ -- -- The constructor will guarantee the correct number and types of the elements. -- The constructor is only exported in the "Data.Diverse.Many.Internal" module -data Many (xs :: [Type]) = Many {-# UNPACK #-} !Int (M.Map Key Any) +data Many (xs :: [Type]) = Many {-# UNPACK #-} !Int (M.Map Int Any) --- | Inferred role is phantom which is incorrect +-- Inferred role is phantom which is incorrect +-- representational means: +-- @ +-- Coercible '[Int] '[IntLike] => Coercible (Many '[Int]) (Many '[IntLike]) +-- @ type role Many representational +-- | Many stored as a list. This is useful when folding over 'Many' efficienty +-- so that the conversion to List is only done once +data Many_ (xs :: [Type]) = Many_ [Any] + +type role Many_ representational + +toMany_ :: Many xs -> Many_ xs +toMany_ (Many _ m) = Many_ (snd <$> M.toAscList m) + +fromMany_ :: Many_ xs -> Many xs +fromMany_ (Many_ xs) = Many 0 (M.fromList (zip [(0 :: Int)..] xs)) ----------------------------------------------------------------------- --- | A terminating 'G.Generic' instance encoded as a 'nul'. +-- | A terminating 'G.Generic' instance encoded as a 'nil'. instance G.Generic (Many '[]) where type Rep (Many '[]) = G.U1 from _ = {- G.U1 -} G.U1 - to G.U1 = nul + to G.U1 = nil -- | A 'G.Generic' instance encoded as the 'front' value 'G.:*:' with the 'aft' 'Many'. -- The 'G.C1' and 'G.S1' metadata are not encoded. instance G.Generic (Many (x ': xs)) where type Rep (Many (x ': xs)) = (G.Rec0 x) G.:*: (G.Rec0 (Many xs)) from r = ({- G.Rec0 -} G.K1 (front r)) G.:*: ({- G.Rec0 -} G.K1 (aft r)) + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE from #-} to (({- G.Rec0 -} G.K1 a) G.:*: ({- G.Rec0 -} G.K1 b)) = a ./ b + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE to #-} ----------------------------------------------------------------------- @@ -190,14 +206,16 @@ -- | @_Many = iso fromMany toMany@ _Many :: IsMany t xs a => Iso' (Many xs) (t xs a) _Many = iso fromMany toMany +{-# INLINE _Many #-} -- | @_Many' = iso fromMany' toMany'@ _Many' :: IsMany Tagged xs a => Iso' (Many xs) a _Many' = iso fromMany' toMany' +{-# INLINE _Many' #-} -- | These instances add about 7 seconds to the compile time! instance IsMany Tagged '[] () where - toMany _ = nul + toMany _ = nil fromMany _ = Tagged () -- | This single field instance is the reason for 'Tagged' wrapper. @@ -207,72 +225,72 @@ fromMany r = Tagged (fetch @a r) instance IsMany Tagged '[a,b] (a,b) where - toMany (Tagged (a,b)) = a./b./nul + toMany (Tagged (a,b)) = a./b./nil fromMany r = Tagged (fetchN (Proxy @0) r, fetchN (Proxy @1) r) instance IsMany Tagged '[a,b,c] (a,b,c) where - toMany (Tagged (a,b,c)) = a./b./c./nul + toMany (Tagged (a,b,c)) = a./b./c./nil fromMany r = Tagged (fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r) instance IsMany Tagged '[a,b,c,d] (a,b,c,d) where - toMany (Tagged (a,b,c,d)) = a./b./c./d./nul + toMany (Tagged (a,b,c,d)) = a./b./c./d./nil fromMany r = Tagged (fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r) instance IsMany Tagged '[a,b,c,d,e] (a,b,c,d,e) where - toMany (Tagged (a,b,c,d,e)) = a./b./c./d./e./nul + toMany (Tagged (a,b,c,d,e)) = a./b./c./d./e./nil fromMany r = Tagged (fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r, fetchN (Proxy @4) r) instance IsMany Tagged '[a,b,c,d,e,f] (a,b,c,d,e,f) where - toMany (Tagged (a,b,c,d,e,f)) = a./b./c./d./e./f./nul + toMany (Tagged (a,b,c,d,e,f)) = a./b./c./d./e./f./nil fromMany r = Tagged ( fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r, fetchN (Proxy @4) r , fetchN (Proxy @5) r) instance IsMany Tagged '[a,b,c,d,e,f,g] (a,b,c,d,e,f,g) where - toMany (Tagged (a,b,c,d,e,f,g)) = a./b./c./d./e./f./g./nul + toMany (Tagged (a,b,c,d,e,f,g)) = a./b./c./d./e./f./g./nil fromMany r = Tagged ( fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r, fetchN (Proxy @4) r , fetchN (Proxy @5) r, fetchN (Proxy @6) r) instance IsMany Tagged '[a,b,c,d,e,f,g,h] (a,b,c,d,e,f,g,h) where - toMany (Tagged (a,b,c,d,e,f,g,h)) = a./b./c./d./e./f./g./h./nul + toMany (Tagged (a,b,c,d,e,f,g,h)) = a./b./c./d./e./f./g./h./nil fromMany r = Tagged ( fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r, fetchN (Proxy @4) r , fetchN (Proxy @5) r, fetchN (Proxy @6) r, fetchN (Proxy @7) r) instance IsMany Tagged '[a,b,c,d,e,f,g,h,i] (a,b,c,d,e,f,g,h,i) where - toMany (Tagged (a,b,c,d,e,f,g,h,i)) = a./b./c./d./e./f./g./h./i./ nul + toMany (Tagged (a,b,c,d,e,f,g,h,i)) = a./b./c./d./e./f./g./h./i./ nil fromMany r = Tagged ( fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r, fetchN (Proxy @4) r , fetchN (Proxy @5) r, fetchN (Proxy @6) r, fetchN (Proxy @7) r, fetchN (Proxy @8) r) instance IsMany Tagged '[a,b,c,d,e,f,g,h,i,j] (a,b,c,d,e,f,g,h,i,j) where - toMany (Tagged (a,b,c,d,e,f,g,h,i,j)) = a./b./c./d./e./f./g./h./i./j./nul + toMany (Tagged (a,b,c,d,e,f,g,h,i,j)) = a./b./c./d./e./f./g./h./i./j./nil fromMany r = Tagged ( fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r, fetchN (Proxy @4) r , fetchN (Proxy @5) r, fetchN (Proxy @6) r, fetchN (Proxy @7) r, fetchN (Proxy @8) r, fetchN (Proxy @9) r) instance IsMany Tagged '[a,b,c,d,e,f,g,h,i,j,k] (a,b,c,d,e,f,g,h,i,j,k) where - toMany (Tagged (a,b,c,d,e,f,g,h,i,j,k)) = a./b./c./d./e./f./g./h./i./j./k./nul + toMany (Tagged (a,b,c,d,e,f,g,h,i,j,k)) = a./b./c./d./e./f./g./h./i./j./k./nil fromMany r = Tagged ( fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r, fetchN (Proxy @4) r , fetchN (Proxy @5) r, fetchN (Proxy @6) r, fetchN (Proxy @7) r, fetchN (Proxy @8) r, fetchN (Proxy @9) r , fetchN (Proxy @10) r) instance IsMany Tagged '[a,b,c,d,e,f,g,h,i,j,k,l] (a,b,c,d,e,f,g,h,i,j,k,l) where - toMany (Tagged (a,b,c,d,e,f,g,h,i,j,k,l)) = a./b./c./d./e./f./g./h./i./j./k./l./nul + toMany (Tagged (a,b,c,d,e,f,g,h,i,j,k,l)) = a./b./c./d./e./f./g./h./i./j./k./l./nil fromMany r = Tagged ( fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r, fetchN (Proxy @4) r , fetchN (Proxy @5) r, fetchN (Proxy @6) r, fetchN (Proxy @7) r, fetchN (Proxy @8) r, fetchN (Proxy @9) r , fetchN (Proxy @10) r, fetchN (Proxy @11) r) instance IsMany Tagged '[a,b,c,d,e,f,g,h,i,j,k,l,m] (a,b,c,d,e,f,g,h,i,j,k,l,m) where - toMany (Tagged (a,b,c,d,e,f,g,h,i,j,k,l,m)) = a./b./c./d./e./f./g./h./i./j./k./l./m./nul + toMany (Tagged (a,b,c,d,e,f,g,h,i,j,k,l,m)) = a./b./c./d./e./f./g./h./i./j./k./l./m./nil fromMany r = Tagged ( fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r, fetchN (Proxy @4) r , fetchN (Proxy @5) r, fetchN (Proxy @6) r, fetchN (Proxy @7) r, fetchN (Proxy @8) r, fetchN (Proxy @9) r , fetchN (Proxy @10) r, fetchN (Proxy @11) r, fetchN (Proxy @12) r) instance IsMany Tagged '[a,b,c,d,e,f,g,h,i,j,k,l,m,n] (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where - toMany (Tagged (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) = a./b./c./d./e./f./g./h./i./j./k./l./m./n./nul + toMany (Tagged (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) = a./b./c./d./e./f./g./h./i./j./k./l./m./n./nil fromMany r = Tagged ( fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r, fetchN (Proxy @4) r , fetchN (Proxy @5) r, fetchN (Proxy @6) r, fetchN (Proxy @7) r, fetchN (Proxy @8) r, fetchN (Proxy @9) r , fetchN (Proxy @10) r, fetchN (Proxy @11) r, fetchN (Proxy @12) r, fetchN (Proxy @13) r) instance IsMany Tagged '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o] (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where - toMany (Tagged (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) = a./b./c./d./e./f./g./h./i./j./k./l./m./n./o./nul + toMany (Tagged (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) = a./b./c./d./e./f./g./h./i./j./k./l./m./n./o./nil fromMany r = Tagged ( fetchN (Proxy @0) r, fetchN (Proxy @1) r, fetchN (Proxy @2) r, fetchN (Proxy @3) r, fetchN (Proxy @4) r , fetchN (Proxy @5) r, fetchN (Proxy @6) r, fetchN (Proxy @7) r, fetchN (Proxy @8) r, fetchN (Proxy @9) r , fetchN (Proxy @10) r, fetchN (Proxy @11) r, fetchN (Proxy @12) r, fetchN (Proxy @13) r, fetchN (Proxy @14) r) @@ -288,16 +306,17 @@ -- So we need to adjust the existing index on the RightMap by -- \OldRightKey -> RightIndex + LeftOffset + LeftSize (as above) -- \OldRightKey -> OldRightKey - RightOffset + LeftOffset + LeftSize -rightKeyForSnoc :: LeftOffset -> LeftSize -> RightOffset -> Key -> Key -rightKeyForSnoc (LeftOffset lo) (LeftSize ld) (RightOffset ro) (Key rk) = - Key (rk - ro + lo + ld) +rightKeyForSnoc :: Int -> Int -> Int -> Int -> Int +rightKeyForSnoc lo ld ro rk = rk - ro + lo + ld +{-# INLINE rightKeyForSnoc #-} -- | When appending two maps together, get the function to modify the RightMap's offset -- when adding LeftMap into RightMap. -- The existing contents of RightMap will not be changed. -- NewRightOffset = OldRightOffset - LeftSize -rightOffsetForCons :: LeftSize -> RightOffset -> NewRightOffset -rightOffsetForCons (LeftSize ld) (RightOffset ro) = NewRightOffset (ro - ld) +rightOffsetForCons :: Int -> Int -> Int +rightOffsetForCons ld ro = ro - ld +{-# INLINE rightOffsetForCons #-} -- | When appending two maps together, get the function to 'M.mapKeys' the LeftMap -- when adding LeftMap into RightMap. @@ -308,30 +327,33 @@ -- So we need to adjust the existing index on the LeftMap by -- \OldLeftKey -> LeftIndex + NewRightOffset (as above) -- \OldLeftKey -> OldLeftKey - LeftOffset + NewRightOffset (as above) -leftKeyForCons :: LeftOffset -> NewRightOffset -> Key -> Key -leftKeyForCons (LeftOffset lo) (NewRightOffset ro) (Key lk) = Key (lk - lo + ro) +leftKeyForCons :: Int -> Int -> Int -> Int +leftKeyForCons lo ro lk = lk - lo + ro +{-# INLINE leftKeyForCons #-} --- | Analogous to 'Prelude.null'. Named 'nul' to avoid conflicting with 'Prelude.null'. -nul :: Many '[] -nul = Many 0 M.empty -infixr 5 `nul` -- to be the same as 'prefix' +-- | Analogous to 'Prelude.nill'. Named 'nil' to avoid conflicting with 'Prelude.nill'. +nil :: Many '[] +nil = Many 0 M.empty -- | Create a Many from a single value. Analogous to 'M.singleton' single :: x -> Many '[x] -single v = Many 0 (M.singleton (Key 0) (unsafeCoerce v)) +single v = Many 0 (M.singleton 0 (unsafeCoerce v)) -- | Add an element to the left of a Many. -- Not named @cons@ to avoid conflict with 'Control.Lens.cons' prefix :: x -> Many xs -> Many (x ': xs) -prefix x (Many ro rm) = Many (unNewRightOffset nro) +prefix x (Many ro rm) = Many nro (M.insert - (leftKeyForCons (LeftOffset 0) nro (Key 0)) + (leftKeyForCons 0 nro 0) (unsafeCoerce x) rm) where - nro = rightOffsetForCons (LeftSize 1) (RightOffset ro) + nro = rightOffsetForCons 1 ro infixr 5 `prefix` +prefix' :: x -> Many_ xs -> Many_ (x ': xs) +prefix' x (Many_ xs) = Many_ (unsafeCoerce x : xs) + -- | Infix version of 'prefix'. -- -- Mnemonic: Element on the left is smaller './' than the larger 'Many' to the right. @@ -343,7 +365,7 @@ -- Not named 'snoc' to avoid conflict with 'Control.Lens.snoc' postfix :: Many xs -> y -> Many (Append xs '[y]) postfix (Many lo lm) y = Many lo - (M.insert (rightKeyForSnoc (LeftOffset lo) (LeftSize (M.size lm)) (RightOffset 0) (Key 0)) + (M.insert (rightKeyForSnoc lo (M.size lm) 0 0) (unsafeCoerce y) lm) infixl 5 `postfix` @@ -363,14 +385,14 @@ append (Many lo lm) (Many ro rm) = if ld >= rd then Many lo - (lm `M.union` (M.mapKeys (rightKeyForSnoc (LeftOffset lo) (LeftSize ld) (RightOffset ro)) rm)) + (lm `M.union` (M.mapKeys (rightKeyForSnoc lo ld ro) rm)) else Many - (unNewRightOffset nro) - ((M.mapKeys (leftKeyForCons (LeftOffset lo) nro) lm) `M.union` rm) + nro + ((M.mapKeys (leftKeyForCons lo nro) lm) `M.union` rm) where ld = M.size lm rd = M.size rm - nro = rightOffsetForCons (LeftSize ld) (RightOffset ro) + nro = rightOffsetForCons ld ro infixr 5 `append` -- like Data.List (++) ----------------------------------------------------------------------- @@ -380,6 +402,9 @@ front :: Many (x ': xs) -> x front (Many _ m) = unsafeCoerce (snd . Partial.head $ M.toAscList m) +front' :: Many_ (x ': xs) -> x +front' (Many_ xs) = unsafeCoerce (Partial.head xs) + -- | Extract the 'back' element of a Many, which guaranteed to be non-empty. -- Analogous to 'Prelude.last' back :: Many (x ': xs) -> Last (x ': xs) @@ -388,32 +413,54 @@ -- | Extract the elements after the front of a Many, which guaranteed to be non-empty. -- Analogous to 'Partial.tail' aft :: Many (x ': xs) -> Many xs -aft (Many o m) = Many (o + 1) (M.delete (Key o) m) +aft (Many o m) = Many (o + 1) (M.delete o m) +aft' :: Many_ (x ': xs) -> Many_ xs +aft' (Many_ xs) = Many_ (Partial.tail xs) + -- | Return all the elements of a Many except the 'back' one, which guaranteed to be non-empty. -- Analogous to 'Prelude.init' fore :: Many (x ': xs) -> Many (Init (x ': xs)) -fore (Many o m) = Many o (M.delete (Key (o + M.size m - 1)) m) +fore (Many o m) = Many o (M.delete (o + M.size m - 1) m) -------------------------------------------------- -- | Getter by unique type. Get the field with type @x@. -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nil' -- 'fetch' \@Int x \`shouldBe` 5 -- @ fetch :: forall x xs. UniqueMember x xs => Many xs -> x -fetch (Many o m) = unsafeCoerce (m M.! (Key (o + i))) - where i = fromInteger (natVal @(IndexOf x xs) Proxy) +fetch = fetch_ +fetch_ :: forall x xs n. (KnownNat n, n ~ IndexOf x xs) => Many xs -> x +fetch_ (Many o m) = unsafeCoerce (m M.! (o + i)) + where i = fromInteger (natVal @n Proxy) + -------------------------------------------------- +-- | Getter by label. Get the value of the field with tag @label@ which can be any type +-- not just @KnownSymbol@. +-- @ +-- +-- let y = False './' Tagged \@Foo \'X' './' Tagged @"Hi" True './' 'nil' +-- 'fetchL' \@Foo Proxy y \`shouldBe` Tagged \@Foo \'X' +-- 'fetchL' \@"Hi" Proxy y \`shouldBe` Tagged \@"Hi" True +-- @ +fetchL :: forall l xs x proxy. (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => proxy l -> Many xs -> x +fetchL _ = fetch_ @x + +-------------------------------------------------- + -- | Getter by index. Get the value of the field at index type-level Nat @n@ -- --- @getchN (Proxy \@2) t@ +-- @ +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nil' +-- 'fetchN' @1 Proxy x \`shouldBe` False +-- @ fetchN :: forall n x xs proxy. MemberAt n x xs => proxy n -> Many xs -> x -fetchN p (Many o m) = unsafeCoerce (m M.! (Key (o + i))) +fetchN p (Many o m) = unsafeCoerce (m M.! (o + i)) where i = fromInteger (natVal p) -------------------------------------------------- @@ -421,38 +468,70 @@ -- | Setter by unique type. Set the field with type @x@. -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nul' --- 'replace' \@Int x 6 \`shouldBe` (6 :: Int) './' False './' \'X' './' Just \'O' './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nil' +-- 'replace' \@Int x 6 \`shouldBe` (6 :: Int) './' False './' \'X' './' Just \'O' './' 'nil' -- @ replace :: forall x xs. UniqueMember x xs => Many xs -> x -> Many xs -replace (Many o m) v = Many o (M.insert (Key (o + i)) (unsafeCoerce v) m) - where i = fromInteger (natVal @(IndexOf x xs) Proxy) +replace = replace_ +replace_ :: forall x xs n. (KnownNat n, n ~ IndexOf x xs) => Many xs -> x -> Many xs +replace_ (Many o m) v = Many o (M.insert (o + i) (unsafeCoerce v) m) + where i = fromInteger (natVal @n Proxy) + -- | Polymorphic setter by unique type. Set the field with type @x@, and replace with type @y@ -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nul' --- 'replace'' \@Int Proxy x (Just True) \`shouldBe` Just True './' False './' \'X' './' Just \'O' './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nil' +-- 'replace'' \@Int Proxy x (Just True) \`shouldBe` Just True './' False './' \'X' './' Just \'O' './' 'nil' -- @ -replace' :: forall x y xs. UniqueMember x xs => Proxy x -> Many xs -> y -> Many (Replace x y xs) -replace' _ (Many o m) v = Many o (M.insert (Key (o + i)) (unsafeCoerce v) m) - where i = fromInteger (natVal @(IndexOf x xs) Proxy) +replace' :: forall x y xs proxy. UniqueMember x xs => proxy x -> Many xs -> y -> Many (Replace x y xs) +replace' = replace'_ +replace'_ :: forall x y xs n proxy. (KnownNat n, n ~ IndexOf x xs) => proxy x -> Many xs -> y -> Many (Replace x y xs) +replace'_ _ (Many o m) v = Many o (M.insert (o + i) (unsafeCoerce v) m) + where i = fromInteger (natVal @n Proxy) + -------------------------------------------------- +-- | Setter by unique label. Set the field with label @l@. +-- +-- @ +-- let y = (5 :: Int) './' False './' Tagged \@Foo \'X' './' Tagged \@\"Hello" (6 :: Int) './' 'nil' +-- 'replaceL' \@Foo Proxy y (Tagged \@Foo \'Y') \`shouldBe` +-- (5 :: Int) './' False './' Tagged \@Foo \'Y' './' Tagged \@\"Hello" (6 :: Int) './' 'nil' +-- 'replaceL' \@\"Hello" Proxy y (Tagged \@\"Hello" 7) \`shouldBe` +-- (5 :: Int) './' False './' Tagged \@Foo \'X' './' Tagged \@\"Hello" (7 :: Int) './' 'nil' +-- @ +replaceL :: forall l xs x proxy. (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => proxy l -> Many xs -> x -> Many xs +replaceL _ = replace_ @x + +-- | Polymorphic setter by unique type. Set the field with type @x@, and replace with type @y@ +-- +-- @ +-- let y = (5 :: Int) './' False './' Tagged \@Foo \'X' './' Tagged \@\"Hello" (6 :: Int) './' 'nil' +-- replaceL' \@Foo Proxy y (Tagged \@Bar \'Y') `shouldBe` +-- (5 :: Int) './' False './' Tagged @Bar 'Y' './' Tagged @"Hello" (6 :: Int) './' 'nil' +-- replaceL' \@\"Hello" Proxy y (Tagged \@\"Hello" False) \`shouldBe` +-- (5 :: Int) './' False './' Tagged \@Foo \'X' './' Tagged \@\"Hello" False './' 'nil' +-- @ +replaceL' :: forall l y xs x proxy. (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => proxy l -> Many xs -> y -> Many (Replace x y xs) +replaceL' _ = replace'_ @x Proxy + +-------------------------------------------------- + -- | Setter by index. Set the value of the field at index type-level Nat @n@ -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nil' -- 'replaceN' \@0 Proxy x 7 `shouldBe` -- @ replaceN :: forall n x y xs proxy. MemberAt n x xs => proxy n -> Many xs -> y -> Many xs -replaceN p (Many o m) v = Many o (M.insert (Key (o + i)) (unsafeCoerce v) m) +replaceN p (Many o m) v = Many o (M.insert (o + i) (unsafeCoerce v) m) where i = fromInteger (natVal p) -- | Polymorphic version of 'replaceN' replaceN' :: forall n x y xs proxy. MemberAt n x xs => proxy n -> Many xs -> y -> Many (ReplaceIndex n y xs) -replaceN' p (Many o m) v = Many o (M.insert (Key (o + i)) (unsafeCoerce v) m) +replaceN' p (Many o m) v = Many o (M.insert (o + i) (unsafeCoerce v) m) where i = fromInteger (natVal p) ----------------------------------------------------------------------- @@ -460,9 +539,9 @@ -- | 'fetch' ('view' 'item') and 'replace' ('set' 'item') in 'Lens'' form. -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nil' -- x '^.' 'item' \@Int \`shouldBe` 5 --- (x '&' 'item' \@Int .~ 6) \`shouldBe` (6 :: Int) './' False './' \'X' './' Just \'O' './' 'nul' +-- (x '&' 'item' \@Int .~ 6) \`shouldBe` (6 :: Int) './' False './' \'X' './' Just \'O' './' 'nil' -- @ item :: forall x xs. UniqueMember x xs => Lens' (Many xs) x item = lens fetch replace @@ -473,12 +552,35 @@ item' = lens fetch (replace' @x @y Proxy) {-# INLINE item' #-} + +-- | 'fetchL' ('view' 'itemL') and 'replaceL' ('set' 'itemL') in 'Lens'' form. +-- +-- @ +-- 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' +-- @ +itemL :: forall l xs x proxy. (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => proxy l -> Lens' (Many xs) x +itemL p = lens (fetchL p) (replaceL p) +{-# INLINE itemL #-} + +-- | Polymorphic version of 'itemL' +-- +-- @ +-- let x = (5 :: Int) './' Tagged @Foo False './' Tagged \@Bar \'X' './' 'nil' +-- (x '&' itemL' \@Foo Proxy '.~' \"foo") \`shouldBe` (5 :: Int) './' \"foo" './' Tagged \@Bar \'X' './' 'nil' +-- @ +itemL' :: forall l y xs x proxy. (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => proxy l -> Lens (Many xs) (Many (Replace x y xs)) x y +itemL' p = lens (fetchL p) (replaceL' p) +{-# INLINE itemL' #-} + + -- | 'fetchN' ('view' 'item') and 'replaceN' ('set' 'item') in 'Lens'' form. -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' ./ nul +-- 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' './' 'nul' +-- (x '&' 'itemN' (Proxy @0) '.~' 6) \`shouldBe` (6 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nil' -- @ itemN :: forall n x xs proxy. MemberAt n x xs => proxy n -> Lens' (Many xs) x itemN p = lens (fetchN p) (replaceN p) @@ -498,27 +600,87 @@ ----------------------------------------------------------------------- --- | Wraps a 'Case' into an instance of 'Emit', 'reiterate'ing and feeding 'Case' with the value from the 'Many' --- and 'emit'ting the results. +class CaseAny c (xs :: [Type]) r where + -- | Return the handler/continuation when x is observed. + caseAny :: c xs r -> Any -> r + +----------------------------------------------------------------------- + +-- | Variation of 'Collector' which uses 'CaseAny' instead of 'Case' +data CollectorAny c (xs :: [Type]) r = CollectorAny (c xs r) [Any] + +-- | nill case that doesn't even use 'caseAny', so that an instance of @CaseAny '[]@ is not needed. +instance AFoldable (CollectorAny c '[]) r where + afoldr _ z _ = z + +instance ( CaseAny c (x ': xs) r + , Reiterate c (x ': xs) + , AFoldable (CollectorAny c xs) r + ) => + AFoldable (CollectorAny c (x ': xs)) r where + afoldr f z (CollectorAny c xs) = f (caseAny c x) (afoldr f z (CollectorAny (reiterate c) xs')) + where + -- use of head/tail here is safe as we are guaranteed the length from the typelist + x = Partial.head xs + xs' = Partial.tail xs + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE afoldr #-} + +forMany' :: c xs r -> Many xs -> CollectorAny c xs r +forMany' c (Many _ xs) = CollectorAny c (snd <$> M.toAscList xs) + +----------------------------------------------------------------------- + +-- | A variation of 'CollectorN' which uses 'CaseAny' instead of 'Case' +data CollectorAnyN c n (xs :: [Type]) r = CollectorAnyN (c n xs r) [Any] + +-- | nill case that doesn't even use 'caseAnyN', so that an instance of @CaseAnyN '[]@ is not needed. +instance AFoldable (CollectorAnyN c n '[]) r where + afoldr _ z _ = z + +instance ( CaseAny (c n) (x ': xs) r + , ReiterateN c n (x ': xs) + , AFoldable (CollectorAnyN c (n + 1) xs) r + ) => + AFoldable (CollectorAnyN c n (x ': xs)) r where + afoldr f z (CollectorAnyN c xs) = f (caseAny c x) (afoldr f z (CollectorAnyN (reiterateN c) xs')) + where + -- use of head/tail here is safe as we are guaranteed the length from the typelist + x = Partial.head xs + xs' = Partial.tail xs + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE afoldr #-} + +forManyN' :: c n xs r -> Many xs -> CollectorAnyN c n xs r +forManyN' c (Many _ xs) = CollectorAnyN c (snd <$> M.toAscList xs) + +----------------------------------------------------------------------- + +-- | Collects the output from 'case''ing each field in a 'Many'. +-- Uses 'Reiterate' to prepare the 'Case' to accept the next type in the @xs@ typelist. -- --- Internally, this holds the left-over [(k, v)] from the original 'Many' for the remaining typelist @xs@. +-- Internally, this holds the left-over [(k, v)] from the original 'Many' for the remaining typelist @xs@. -- --- That is the first v in the (k, v) is of type @x@, and the length of the list is equal to the length of @xs@. -newtype Via c (xs :: [Type]) r = Via (c xs r, [Any]) - --- | Creates an 'Via' safely, so that the invariant of \"typelist to the value list type and size\" holds. -via :: c xs r -> Many xs -> Via c xs r -via c (Many _ m) = Via (c, snd <$> M.toAscList m) +-- That is, the first v in the (k, v) is of type @x@, and the length of the list is equal to the length of @xs@. +data Collector c (xs :: [Type]) r = Collector (c xs r) [Any] -instance Reiterate c (x ': xs) => Reiterate (Via c) (x ': xs) where - -- use of tail here is safe as we are guaranteed the length from the typelist - reiterate (Via (c, xxs)) = Via (reiterate c, Partial.tail xxs) +-- | nill case that doesn't even use 'case'', so that an instance of @Case '[]@ is not needed. +instance AFoldable (Collector c '[]) r where + afoldr _ z _ = z -instance (Case c (x ': xs) r) => Emit (Via c) (x ': xs) r where - emit (Via (c, xxs)) = caseAny c v +-- | Folds values by 'reiterate'ing 'Emit'ters through the @xs@ typelist. +instance ( Case c (x ': xs) r + , Reiterate c (x ': xs) + , AFoldable (Collector c xs) r + ) => + AFoldable (Collector c (x ': xs)) r where + afoldr f z (Collector c xs) = f (case' c v) (afoldr f z (Collector (reiterate c) xs')) where - -- use of front here is safe as we are guaranteed the length from the typelist - v = Partial.head xxs + -- use of head/tail here is safe as we are guaranteed the length from the typelist + v = unsafeCoerce $ Partial.head xs + xs' = Partial.tail xs + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE afoldr #-} ----------------------------------------------------------------------- @@ -529,43 +691,47 @@ -- The 'Collector' is 'AFoldable' to combine the results. -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nul' --- y = show \@Int './' show \@Char './' show \@(Maybe Char) './' show \@Bool './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nil' +-- y = show \@Int './' show \@Char './' show \@(Maybe Char) './' show \@Bool './' 'nil' -- 'afoldr' (:) [] ('forMany' ('Data.Diverse.Cases.cases' y) x) \`shouldBe` -- [\"5", \"False", \"\'X'", \"Just \'O'", \"6", \"Just \'A'"] -- @ -forMany :: c xs r -> Many xs -> Collector (Via c) xs r -forMany c x = Collector (via c x) +forMany :: c xs r -> Many xs -> Collector c xs r +forMany c (Many _ xs) = Collector c (snd <$> M.toAscList xs) -- | This is @flip 'forMany'@ -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nul' --- y = show \@Int './' show \@Char './' show \@(Maybe Char) './' show \@Bool './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nil' +-- y = show \@Int './' show \@Char './' show \@(Maybe Char) './' show \@Bool './' 'nil' -- 'afoldr' (:) [] ('collect' x ('Data.Diverse.Cases.cases' y)) \`shouldBe` -- [\"5", \"False", \"\'X'", \"Just \'O'", \"6", \"Just \'A'"] -- @ -collect :: Many xs -> c xs r -> Collector (Via c) xs r +collect :: Many xs -> c xs r -> Collector c xs r collect = flip forMany ----------------------------------------------------------------------- --- | A variation of 'Via' which __'reiterateN'__ instead. -newtype ViaN c (n :: Nat) (xs :: [Type]) r = ViaN (c n xs r, [Any]) - --- | Creates an 'ViaN' safely, so that the invariant of \"typelist to the value list type and size\" holds. -viaN :: c n xs r -> Many xs -> ViaN c n xs r -viaN c (Many _ m) = ViaN (c, snd <$> M.toAscList m) +-- | A variation of 'Collector' which uses 'ReiterateN' instead of 'Reiterate' +data CollectorN c (n :: Nat) (xs :: [Type]) r = CollectorN (c n xs r) [Any] -instance ReiterateN c n (x ': xs) => ReiterateN (ViaN c) n (x ': xs) where - -- use of tail here is safe as we are guaranteed the length from the typelist - reiterateN (ViaN (c, xxs)) = ViaN (reiterateN c, Partial.tail xxs) +-- | nill case that doesn't even use 'case'', so that an instance of @Case '[]@ is not needed. +instance AFoldable (CollectorN c n '[]) r where + afoldr _ z _ = z -instance (Case (c n) (x ': xs) r) => Emit (ViaN c n) (x ': xs) r where - emit (ViaN (c, xxs)) = caseAny c v +-- | Folds values by 'reiterate'ing 'Emit'ters through the @xs@ typelist. +instance ( Case (c n) (x ': xs) r + , ReiterateN c n (x ': xs) + , AFoldable (CollectorN c (n + 1) xs) r + ) => + AFoldable (CollectorN c n (x ': xs)) r where + afoldr f z (CollectorN c xs) = f (case' c v) (afoldr f z (CollectorN (reiterateN c) xs')) where - -- use of front here is safe as we are guaranteed the length from the typelist - v = Partial.head xxs + -- use of head/tail here is safe as we are guaranteed the length from the typelist + v = unsafeCoerce $ Partial.head xs + xs' = Partial.tail xs + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE afoldr #-} -- | Folds any 'Many', even with indistinct types. -- Given __index__ handlers for the fields in 'Many', create a 'CollectorN' @@ -574,23 +740,23 @@ -- The 'CollectorN' is 'AFoldable' to combine the results. -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nul' --- y = show \@Int './' show \@Bool './' show \@Char './' show \@(Maybe Char) './' show \@Int './' show \@(Maybe Char) './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nil' +-- y = show \@Int './' show \@Bool './' show \@Char './' show \@(Maybe Char) './' show \@Int './' show \@(Maybe Char) './' 'nil' -- 'afoldr' (:) [] ('forManyN' ('Data.Diverse.Cases.casesN' y) x) \`shouldBe` -- [\"5", \"False", \"\'X'", \"Just \'O'", \"6", \"Just \'A'"] -- @ -forManyN :: c n xs r -> Many xs -> CollectorN (ViaN c) n xs r -forManyN c x = CollectorN (viaN c x) +forManyN :: c n xs r -> Many xs -> CollectorN c n xs r +forManyN c (Many _ xs) = CollectorN c (snd <$> M.toAscList xs) -- | This is @flip 'forManyN'@ -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nul' --- y = show \@Int './' show \@Bool './' show \@Char './' show \@(Maybe Char) './' show \@Int './' show \@(Maybe Char) './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nil' +-- y = show \@Int './' show \@Bool './' show \@Char './' show \@(Maybe Char) './' show \@Int './' show \@(Maybe Char) './' 'nil' -- 'afoldr' (:) [] ('collectN' x ('Data.Diverse.Cases.casesN' y)) \`shouldBe` -- [\"5", \"False", \"\'X'", \"Just \'O'", \"6", \"Just \'A'"] -- @ -collectN :: Many xs -> c n xs r -> CollectorN (ViaN c) n xs r +collectN :: Many xs -> c n xs r -> CollectorN c n xs r collectN = flip forManyN ----------------------------------------------------------------------- @@ -598,7 +764,7 @@ -- | A friendlier type constraint synomyn for 'select' type Select (smaller :: [Type]) (larger :: [Type]) = (AFoldable - ( Collector (Via (CaseSelect smaller larger)) larger) [(Key, WrappedAny)]) + ( CollectorAny (CaseSelect smaller larger) larger) (Maybe (Int, WrappedAny))) -- | Construct a 'Many' with a smaller number of fields than the original. -- Analogous to 'fetch' getter but for multiple fields. @@ -606,35 +772,53 @@ -- This can also be used to reorder fields in the original 'Many'. -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nul' --- 'select' \@'[Bool, Char] x \`shouldBe` False './' \'X' './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nil' +-- 'select' \@'[Bool, Char] x \`shouldBe` False './' \'X' './' 'nil' -- @ select :: forall smaller larger. Select smaller larger => Many larger -> Many smaller select t = Many 0 (fromList' xs') where - xs' = afoldr (++) [] (Collector (via (CaseSelect @smaller @larger @larger) t)) + xs' = afoldr (\a z -> maybe z (: z) a) [] (forMany' (CaseSelect @smaller @larger @larger) t) -- | For each type x in @larger@, generate the (k, v) in @smaller@ (if it exists) data CaseSelect (smaller :: [Type]) (larger :: [Type]) (xs :: [Type]) r = CaseSelect instance Reiterate (CaseSelect smaller larger) (x ': xs) where - reiterate CaseSelect = CaseSelect + reiterate = coerce --- | For each type x in larger, find the index in ys, and create an (incrementing key, value) -instance forall smaller larger x xs. (UniqueIfExists smaller x larger, MaybeUniqueMember x smaller) => - Case (CaseSelect smaller larger) (x ': xs) [(Key, WrappedAny)] where +-- | For each type x in larger, find the index in ys, and create a (key, value) +instance forall smaller larger x xs n. (UniqueIfExists smaller x larger, MaybeUniqueMemberAt n x smaller) => + CaseAny (CaseSelect smaller larger) (x ': xs) (Maybe (Int, WrappedAny)) where caseAny _ v = case i of - 0 -> [] - i' -> [(Key (i' - 1), WrappedAny v)] + 0 -> Nothing + i' -> Just (i' - 1, WrappedAny v) where - i = fromInteger (natVal @(PositionOf x smaller) Proxy) + i = fromInteger (natVal @n Proxy) ----------------------------------------------------------------------- +-- | A variation of 'select' which selects by labels +-- +-- @ +-- let x = False './' Tagged \@\"Hi" (5 :: Int) './' Tagged \@Foo False './' Tagged \@Bar \'X' './' Tagged \@\"Bye" 'O' './' 'nil' +-- 'selectL' \@'[Foo, Bar] Proxy x \`shouldBe` Tagged \@Foo False './' Tagged \@Bar \'X' './' 'nil' +-- 'selectL' \@'[\"Hi", \"Bye"] Proxy x \`shouldBe` Tagged \@\"Hi" (5 :: Int) './' Tagged \@\"Bye" \'O' './' 'nil' +-- @ +selectL + :: forall ls smaller larger proxy. + ( Select smaller larger + , smaller ~ KindsAtLabels ls larger + , IsDistinct ls + , UniqueLabels ls larger) + => proxy ls -> Many larger -> Many smaller +selectL _ = select @smaller + +----------------------------------------------------------------------- + -- | A friendlier type constraint synomyn for 'selectN' type SelectN (ns :: [Nat]) (smaller ::[Type]) (larger :: [Type]) = - ( AFoldable (CollectorN (ViaN (CaseSelectN ns smaller)) 0 larger) [(Key, WrappedAny)] + ( AFoldable (CollectorAnyN (CaseSelectN ns smaller) 0 larger) (Maybe (Int, WrappedAny)) , smaller ~ KindsAtIndices ns larger , IsDistinct ns) @@ -648,8 +832,8 @@ -- the mapping is specified by @indicies@. -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nul' --- 'selectN' (Proxy @'[5, 4, 0]) x \`shouldBe` Just \'A' './' (6 :: Int) './' (5 ::Int) './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nil' +-- 'selectN' (Proxy @'[5, 4, 0]) x \`shouldBe` Just \'A' './' (6 :: Int) './' (5 ::Int) './' 'nil' -- @ selectN :: forall ns smaller larger proxy. @@ -657,7 +841,7 @@ => proxy ns -> Many larger -> Many smaller selectN _ xs = Many 0 (fromList' xs') where - xs' = afoldr (++) [] (forManyN (CaseSelectN @ns @smaller @0 @larger) xs) + xs' = afoldr (\a z -> maybe z (: z) a) [] (forManyN' (CaseSelectN @ns @smaller @0 @larger) xs) data CaseSelectN (indices :: [Nat]) (smaller :: [Type]) (n :: Nat) (xs :: [Type]) r = CaseSelectN @@ -665,76 +849,121 @@ reiterateN CaseSelectN = CaseSelectN -- | For each type x in @larger@, find the index in ys, and create an (incrementing key, value) -instance forall indices smaller n x xs. MaybeMemberAt (PositionOf n indices) x smaller => - Case (CaseSelectN indices smaller n) (x ': xs) [(Key, WrappedAny)] where +instance forall indices smaller n x xs n'. (MaybeMemberAt n' x smaller, n' ~ PositionOf n indices) => + CaseAny (CaseSelectN indices smaller n) (x ': xs) (Maybe (Int, WrappedAny)) where caseAny _ v = case i of - 0 -> [] - i' -> [(Key (i' - 1), WrappedAny v)] + 0 -> Nothing + i' -> Just (i' - 1, WrappedAny v) where - i = fromInteger (natVal @(PositionOf n indices) Proxy) + i = fromInteger (natVal @n' Proxy) ----------------------------------------------------------------------- -- | A friendlier type constraint synomyn for 'amend' -type Amend smaller larger = (AFoldable (Collector (Via (CaseAmend larger)) smaller) (Key, WrappedAny) +type Amend smaller larger = (AFoldable (CollectorAny (CaseAmend larger) smaller) (Int, WrappedAny) , IsDistinct smaller) -- | Sets the subset of 'Many' in the larger 'Many'. -- Analogous to 'replace' setter but for multiple fields. -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nul' --- 'amend' \@'[Int, Maybe Char] x ((6 :: Int) './' Just \'P' './' 'nul') \`shouldBe` --- (6 :: Int) './' False './' \'X' './' Just \'P' './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nil' +-- 'amend' \@'[Int, Maybe Char] x ((6 :: Int) './' Just \'P' './' 'nil') \`shouldBe` +-- (6 :: Int) './' False './' \'X' './' Just \'P' './' 'nil' -- @ amend :: forall smaller larger. Amend smaller larger => Many larger -> Many smaller -> Many larger amend (Many lo lm) t = Many lo (fromList' xs' `M.union` lm) where - xs' = afoldr (:) [] (forMany (CaseAmend @larger @smaller lo) t) + xs' = afoldr (:) [] (forMany' (CaseAmend @larger @smaller lo) t) newtype CaseAmend (larger :: [Type]) (xs :: [Type]) r = CaseAmend Int instance Reiterate (CaseAmend larger) (x ': xs) where - reiterate (CaseAmend lo) = CaseAmend lo + reiterate = coerce -- | for each x in @smaller@, convert it to a (k, v) to insert into the x in @Many larger@ -instance UniqueMember x larger => Case (CaseAmend larger) (x ': xs) (Key, WrappedAny) where - caseAny (CaseAmend lo) v = (Key (lo + i), WrappedAny v) +instance UniqueMemberAt n x larger => CaseAny (CaseAmend larger) (x ': xs) (Int, WrappedAny) where + caseAny (CaseAmend lo) v = (lo + i, WrappedAny v) where - i = fromInteger (natVal @(IndexOf x larger) Proxy) + i = fromInteger (natVal @n Proxy) ----------------------------------------------------------------------- +-- | A variation of 'amend' which amends via labels. +-- +-- @ +-- let x = False ./ Tagged \@\"Hi" (5 :: Int) ./ Tagged \@Foo False ./ Tagged \@Bar \'X' ./ Tagged \@\"Bye" \'O' ./ 'nil' +-- 'amendL' \@'[Foo, Bar] Proxy x (Tagged \@Foo True ./ Tagged \@Bar \'Y' ./ nil) `shouldBe` +-- False ./ Tagged \@\"Hi" (5 :: Int) ./ Tagged \@Foo True ./ Tagged \@Bar \'Y' ./ Tagged \@\"Bye" \'O' ./ 'nil' +-- 'amendL' \@'[\"Hi", \"Bye"] Proxy x (Tagged \@\"Hi" (6 :: Int) ./ Tagged \@\"Bye" \'P' ./ nil) `shouldBe` +-- False ./ Tagged \@\"Hi" (6 :: Int) ./ Tagged \@Foo False ./ Tagged \@Bar \'X' ./ Tagged \@\"Bye" \'P' ./ 'nil' +-- @ +amendL + :: forall ls smaller larger proxy. + ( Amend smaller larger + , smaller ~ KindsAtLabels ls larger + , IsDistinct ls + , UniqueLabels ls larger) + => proxy ls -> Many larger -> Many smaller -> Many larger +amendL _ = amend @(KindsAtLabels ls larger) + +----------------------------------------------------------------------- + -- | A friendlier type constraint synomyn for 'amend'' -type Amend' smaller smaller' larger = (AFoldable (Collector (Via (CaseAmend' larger)) (Zip smaller smaller')) (Key, WrappedAny), IsDistinct smaller) +type Amend' smaller smaller' larger zipped = + ( AFoldable (CollectorAny (CaseAmend' larger) zipped) (Int, WrappedAny) + , IsDistinct smaller + , zipped ~ Zip smaller smaller') -amend' :: forall smaller smaller' larger. Amend' smaller smaller' larger - => Proxy smaller -> Many larger -> Many smaller' -> Many (Replaces smaller smaller' larger) +amend' :: forall smaller smaller' larger proxy zipped. Amend' smaller smaller' larger zipped + => proxy smaller -> Many larger -> Many smaller' -> Many (Replaces smaller smaller' larger) amend' _ (Many lo lm) t = Many lo (fromList' xs' `M.union` lm) where - xs' = afoldr (:) [] (Collector (via' @smaller Proxy (CaseAmend' @larger @(Zip smaller smaller') lo) t)) + xs' = afoldr (:) [] (forMany'' @smaller Proxy (CaseAmend' @larger @zipped lo) t) --- | We are cheating here and saying that the @y@ can be unsafeCoerced into a type of @(x, y)@ --- but we only every coerce from 'Any' back into @y@in the @caseAny (CaseAmend' lo) v@ below. -via' :: Proxy xs -> c (Zip xs ys) r -> Many ys -> Via c (Zip xs ys) r -via' _ c (Many _ m) = Via (c, snd <$> M.toAscList m) +forMany'' :: Proxy xs -> c (Zip xs ys) r -> Many ys -> CollectorAny c (Zip xs ys) r +forMany'' _ c (Many _ ys) = CollectorAny c (snd <$> M.toAscList ys) newtype CaseAmend' (larger :: [Type]) (zs :: [Type]) r = CaseAmend' Int instance Reiterate (CaseAmend' larger) (z ': zs) where - reiterate (CaseAmend' lo) = CaseAmend' lo + reiterate = coerce -- | for each y in @smaller@, convert it to a (k, v) to insert into the x in @Many larger@ -instance UniqueMember x larger => Case (CaseAmend' larger) ((x, y) ': zs) (Key, WrappedAny) where - caseAny (CaseAmend' lo) v = (Key (lo + i), WrappedAny v) +instance (UniqueMemberAt n x larger) => CaseAny (CaseAmend' larger) ((x, y) ': zs) (Int, WrappedAny) where + caseAny (CaseAmend' lo) v = (lo + i, WrappedAny v) where - i = fromInteger (natVal @(IndexOf x larger) Proxy) + i = fromInteger (natVal @n Proxy) ----------------------------------------------------------------------- + +-- | A variation of 'amend' which amends via labels. +-- +-- @ +-- let x = False './' Tagged \@\"Hi" (5 :: Int) './' Tagged \@Foo False './' Tagged \@Bar 'X' './' Tagged \@\"Bye" \'O' './' 'nil' +-- 'amendL'' \@'[Foo, Bar] Proxy x (\'Y' './' True './' 'ni'l) \`shouldBe` +-- False './' Tagged \@\"Hi" (5 :: Int) './' \'Y' './' True './' Tagged \@\"Bye" \'O' './' 'nil' +-- 'amendL'' \@'[\"Hi", \"Bye"] Proxy x (True './' Tagged \@\"Changed" True './' 'nil') \`shouldBe` +-- False './' True './' Tagged \@Foo False './' Tagged \@Bar \'X' './' Tagged \@\"Changed" True './' 'nil' +-- @ +amendL' + :: forall ls smaller smaller' larger proxy zipped. + ( Amend' smaller smaller' larger zipped + , smaller ~ KindsAtLabels ls larger + , IsDistinct ls + , UniqueLabels ls larger + ) + => proxy ls + -> Many larger + -> Many smaller' + -> Many (Replaces smaller smaller' larger) +amendL' _ = amend' @(KindsAtLabels ls larger) Proxy + +----------------------------------------------------------------------- -- | A friendlier type constraint synomyn for 'amendN' type AmendN ns smaller larger = - ( AFoldable (CollectorN (ViaN (CaseAmendN ns larger)) 0 smaller) (Key, WrappedAny) + ( AFoldable (CollectorAnyN (CaseAmendN ns larger) 0 smaller) (Int, WrappedAny) , smaller ~ KindsAtIndices ns larger , IsDistinct ns) @@ -748,61 +977,60 @@ -- the mapping is specified by @indicies@. -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nul' --- 'amendN' (Proxy \@'[5, 4, 0]) x (Just \'B' './' (8 :: Int) './' (4 ::Int) './' 'nul') \`shouldBe` --- (4 :: Int) './' False './' \'X' './' Just \'O' './' (8 :: Int) './' Just \'B' './' 'nul' +-- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nil' +-- 'amendN' (Proxy \@'[5, 4, 0]) x (Just \'B' './' (8 :: Int) './' (4 ::Int) './' 'nil') \`shouldBe` +-- (4 :: Int) './' False './' \'X' './' Just \'O' './' (8 :: Int) './' Just \'B' './' 'nil' -- @ amendN :: forall ns smaller larger proxy. (AmendN ns smaller larger) => proxy ns -> Many larger -> Many smaller -> Many larger amendN _ (Many lo lm) t = Many lo (fromList' xs' `M.union` lm) where - xs' = afoldr (:) [] (forManyN (CaseAmendN @ns @larger @0 @smaller lo) t) - ------------------------------------------------------------------------ + xs' = afoldr (:) [] (forManyN' (CaseAmendN @ns @larger @0 @smaller lo) t) newtype CaseAmendN (indices :: [Nat]) (larger :: [Type]) (n :: Nat) (xs :: [Type]) r = CaseAmendN Int instance ReiterateN (CaseAmendN indices larger) n (x ': xs) where - reiterateN (CaseAmendN lo) = CaseAmendN lo + reiterateN = coerce -- | for each x in @smaller@, convert it to a (k, v) to insert into the x in @larger@ -instance (MemberAt (KindAtIndex n indices) x larger) => - Case (CaseAmendN indices larger n) (x ': xs) (Key, WrappedAny) where - caseAny (CaseAmendN lo) v = (Key (lo + i), WrappedAny v) +instance (MemberAt n' x larger, n' ~ KindAtIndex n indices) => + CaseAny (CaseAmendN indices larger n) (x ': xs) (Int, WrappedAny) where + caseAny (CaseAmendN lo) v = (lo + i, WrappedAny v) where - i = fromInteger (natVal @(KindAtIndex n indices) Proxy) + i = fromInteger (natVal @n' Proxy) +----------------------------------------------------------------------- + -- | A friendlier type constraint synomyn for 'amendN' -type AmendN' ns smaller smaller' larger = - ( AFoldable (CollectorN (ViaN (CaseAmendN' ns larger)) 0 (Zip smaller smaller')) (Key, WrappedAny) +type AmendN' ns smaller smaller' larger zipped = + ( AFoldable (CollectorAnyN (CaseAmendN' ns larger) 0 zipped) (Int, WrappedAny) , smaller ~ KindsAtIndices ns larger - , IsDistinct ns) + , IsDistinct ns + , zipped ~ Zip smaller smaller') -- | A polymorphic variation of 'amendN' -amendN' :: forall ns smaller smaller' larger proxy. - (AmendN' ns smaller smaller' larger) +amendN' :: forall ns smaller smaller' larger proxy zipped. + (AmendN' ns smaller smaller' larger zipped) => proxy ns -> Many larger -> Many smaller' -> Many (ReplacesIndex ns smaller' larger) amendN' _ (Many lo lm) t = Many lo (fromList' xs' `M.union` lm) where - xs' = afoldr (:) [] (CollectorN (viaN' @smaller Proxy (CaseAmendN' @ns @larger @0 @(Zip smaller smaller') lo) t)) + xs' = afoldr (:) [] (forManyN'' @smaller Proxy (CaseAmendN' @ns @larger @0 @zipped lo) t) --- | We are cheating here and saying that the @y@ can be unsafeCoerced into a type of @(x, y)@ --- but we only every coerce from 'Any' back into @y@in the @caseAny (CaseAmend' lo) v@ below. -viaN' :: Proxy xs -> c n (Zip xs ys) r -> Many ys -> ViaN c n (Zip xs ys) r -viaN' _ c (Many _ m) = ViaN (c, snd <$> M.toAscList m) +forManyN'' :: Proxy xs -> c n (Zip xs ys) r -> Many ys -> CollectorAnyN c n (Zip xs ys) r +forManyN'' _ c (Many _ ys) = CollectorAnyN c (snd <$> M.toAscList ys) newtype CaseAmendN' (indices :: [Nat]) (larger :: [Type]) (n :: Nat) (zs :: [Type]) r = CaseAmendN' Int instance ReiterateN (CaseAmendN' indices larger) n (z ': zs) where - reiterateN (CaseAmendN' lo) = CaseAmendN' lo + reiterateN = coerce -- | for each x in @smaller@, convert it to a (k, v) to insert into the x in @larger@ -instance (MemberAt (KindAtIndex n indices) x larger) => - Case (CaseAmendN' indices larger n) ((x, y) ': zs) (Key, WrappedAny) where - caseAny (CaseAmendN' lo) v = (Key (lo + i), WrappedAny v) +instance (MemberAt n' x larger, n' ~ KindAtIndex n indices) => + CaseAny (CaseAmendN' indices larger n) ((x, y) ': zs) (Int, WrappedAny) where + caseAny (CaseAmendN' lo) v = (lo + i, WrappedAny v) where - i = fromInteger (natVal @(KindAtIndex n indices) Proxy) + i = fromInteger (natVal @n' Proxy) ----------------------------------------------------------------------- @@ -813,10 +1041,10 @@ -- @ -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nul' --- x '^.' ('project' \@'[Int, Maybe Char]) \`shouldBe` (5 :: Int) './' Just \'O' './' 'nul' --- (x '&' ('project' \@'[Int, Maybe Char]) '.~' ((6 :: Int) './' Just 'P' './' 'nul')) \`shouldBe` --- (6 :: Int) './' False './' \'X' './' Just \'P' './' 'nul' +-- 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` +-- (6 :: Int) './' False './' \'X' './' Just \'P' './' 'nil' -- @ project :: forall smaller larger. @@ -827,12 +1055,49 @@ -- | Polymorphic version of project' project' - :: forall smaller smaller' larger. - (Select smaller larger, Amend' smaller smaller' larger) + :: forall smaller smaller' larger zipped. + (Select smaller larger, Amend' smaller smaller' larger zipped) => Lens (Many larger) (Many (Replaces smaller smaller' larger)) (Many smaller) (Many smaller') project' = lens select (amend' @smaller @smaller' Proxy) {-# INLINE project' #-} +-- | '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` +-- False './' Tagged \@\"Hi" (6 :: Int) './' Tagged \@Foo False './' Tagged \@Bar \'X' './' Tagged \@\"Bye" \'P' './' 'nil' +-- @ +projectL + :: forall ls smaller larger proxy. + ( Select smaller larger + , Amend smaller larger + , smaller ~ KindsAtLabels ls larger + , IsDistinct ls + , UniqueLabels ls larger) + => proxy ls -> Lens' (Many larger) (Many smaller) +projectL p = lens (selectL p) (amendL p) +{-# INLINE projectL #-} + +-- | 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` +-- False './' True './' Tagged \@Foo False './' Tagged \@Bar \'X' './' Tagged \@\"Changed" False './' 'nil' +-- @ +projectL' + :: forall ls smaller smaller' larger proxy zipped. + ( Select smaller larger + , Amend' smaller smaller' larger zipped + , smaller ~ KindsAtLabels ls larger + , IsDistinct ls + , UniqueLabels ls larger) + => proxy ls -> Lens (Many larger) (Many (Replaces smaller smaller' larger)) (Many smaller) (Many smaller') +projectL' p = lens (selectL p) (amendL' p) +{-# INLINE projectL' #-} + -- | 'selectN' ('view' 'projectN') and 'amendN' ('set' 'projectN') in 'Lens'' form. -- -- @ @@ -840,10 +1105,10 @@ -- @ -- -- @ --- let x = (5 :: Int) './' False './' \'X' './' Just \'O' './' (6 :: Int) './' Just \'A' './' 'nul' --- x '^.' ('projectN' \@'[5, 4, 0] Proxy) \`shouldBe` Just \'A' './' (6 :: Int) './' (5 ::Int) './' 'nul' --- (x '&' ('projectN' \@'[5, 4, 0] Proxy) '.~' (Just \'B' './' (8 :: Int) './' (4 ::Int) './' nul)) \`shouldBe` --- (4 :: Int) './' False './' \'X' './' Just \'O' './' (8 :: Int) './' Just \'B' './' 'nul' +-- 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` +-- (4 :: Int) './' False './' \'X' './' Just \'O' './' (8 :: Int) './' Just \'B' './' 'nil' -- @ projectN :: forall ns smaller larger proxy. @@ -854,136 +1119,94 @@ -- | Polymorphic version of 'projectN' projectN' - :: forall ns smaller smaller' larger proxy. - (SelectN ns smaller larger, AmendN' ns smaller smaller' larger) + :: forall ns smaller smaller' larger proxy zipped. + (SelectN ns smaller larger, AmendN' ns smaller smaller' larger zipped) => proxy ns -> Lens (Many larger) (Many (ReplacesIndex ns smaller' larger)) (Many smaller) (Many smaller') projectN' p = lens (selectN p) (amendN' p) {-# INLINE projectN' #-} ----------------------------------------------------------------------- --- | Stores the left & right Many and a list of Any which must be the same length and types in xs typelist. -newtype EmitEqMany (xs :: [Type]) r = EmitEqMany ([Any], [Any]) - -instance Reiterate EmitEqMany (x ': xs) where - -- use of tail here is safe as we are guaranteed the length from the typelist - reiterate (EmitEqMany (ls, rs)) = EmitEqMany (Partial.tail ls, Partial.tail rs) - -instance Eq x => Emit EmitEqMany (x ': xs) Bool where - emit (EmitEqMany (ls, rs)) = l == r - where - -- use of front here is safe as we are guaranteed the length from the typelist - l = unsafeCoerce (Partial.head ls) :: x - r = unsafeCoerce (Partial.head rs) :: x +instance Eq (Many_ '[]) where + _ == _ = True -eqMany - :: forall xs. - AFoldable (Collector EmitEqMany xs) Bool - => Many xs -> Many xs -> [Bool] -eqMany (Many _ lm) (Many _ rm) = afoldr (:) [] - (Collector (EmitEqMany @xs (snd <$> M.toAscList lm, snd <$> M.toAscList rm))) +instance (Eq x, Eq (Many_ xs)) => Eq (Many_ (x ': xs)) where + ls == rs = case front' ls == front' rs of + False -> False + _ -> (aft' ls) == (aft' rs) + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE (==) #-} -- | Two 'Many's are equal if all their fields equal -instance AFoldable (Collector EmitEqMany xs) Bool => Eq (Many xs) where - lt == rt = foldr (\e z -> bool False z e) True eqs - where - eqs = eqMany lt rt +instance Eq (Many_ xs) => Eq (Many xs) where + lt == rt = toMany_ lt == toMany_ rt ----------------------------------------------------------------------- --- | Stores the left & right Many and a list of Any which must be the same length and types in xs typelist. -newtype EmitOrdMany (xs :: [Type]) r = EmitOrdMany ([Any], [Any]) - -instance Reiterate EmitOrdMany (x ': xs) where - -- use of tail here is safe as we are guaranteed the length from the typelist - reiterate (EmitOrdMany (ls, rs)) = EmitOrdMany (Partial.tail ls, Partial.tail rs) - -instance Ord x => Emit EmitOrdMany (x ': xs) Ordering where - emit (EmitOrdMany (ls, rs)) = compare l r - where - -- use of front here is safe as we are guaranteed the length from the typelist - l = unsafeCoerce (Partial.head ls) :: x - r = unsafeCoerce (Partial.head rs) :: x +instance Ord (Many_ '[]) where + compare _ _ = EQ -ordMany - :: forall xs. - AFoldable (Collector EmitOrdMany xs) Ordering - => Many xs -> Many xs -> [Ordering] -ordMany (Many _ lm) (Many _ rm) = afoldr (:) [] - (Collector (EmitOrdMany @xs (snd <$> M.toAscList lm, snd <$> M.toAscList rm))) +instance (Ord x, Ord (Many_ xs)) => Ord (Many_ (x ': xs)) where + compare ls rs = case compare (front' ls) (front' rs) of + LT -> LT + GT -> GT + EQ -> compare (aft' ls) (aft' rs) + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE compare #-} -- | Two 'Many's are ordered by 'compare'ing their fields in index order -instance (Eq (Many xs), AFoldable (Collector EmitOrdMany xs) Ordering) => Ord (Many xs) where - compare lt rt = foldr (\o z -> case o of - EQ -> z - o' -> o') EQ ords - where - ords = ordMany lt rt +instance Ord (Many_ xs) => Ord (Many xs) where + compare xs ys = compare (toMany_ xs) (toMany_ ys) ----------------------------------------------------------------------- --- | Internally uses [Any] like Via, except also handle the empty type list. -newtype EmitShowMany (xs :: [Type]) r = EmitShowMany [Any] - -instance Reiterate EmitShowMany (x ': xs) where - -- use of tail here is safe as we are guaranteed the length from the typelist - reiterate (EmitShowMany xxs) = EmitShowMany (Partial.tail xxs) - -instance Emit EmitShowMany '[] ShowS where - emit _ = showString "nul" - +instance Show (Many_ '[]) where + showsPrec d _ = showParen (d > app_prec) $ showString "nil" + where + app_prec = 10 -instance Show x => Emit EmitShowMany (x ': xs) ShowS where - emit (EmitShowMany xxs) = showsPrec (cons_prec + 1) v . showString " ./ " +instance (Show x, Show (Many_ xs)) => Show (Many_ (x ': xs)) where + showsPrec d ls@(Many_ xs) = + showParen (d > cons_prec) $ + showsPrec (cons_prec + 1) v . + showString " ./ " . + showsPrec cons_prec (aft' ls) -- not (cons-prec+1) for right associativity where + cons_prec = 5 -- infixr 5 prefix -- use of front here is safe as we are guaranteed the length from the typelist - v = unsafeCoerce (Partial.head xxs) :: x - cons_prec = 5 -- infixr 5 cons - -showMany - :: forall xs. - AFoldable (Collector0 EmitShowMany xs) ShowS - => Many xs -> ShowS -showMany (Many _ m) = afoldr (.) id (Collector0 (EmitShowMany @xs (snd <$> M.toAscList m))) + v = unsafeCoerce (Partial.head xs) :: x + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE showsPrec #-} --- | @read "5 ./ False ./ 'X' ./ Just 'O' ./ nul" == (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nul'@ -instance AFoldable (Collector0 EmitShowMany xs) ShowS => Show (Many xs) where - showsPrec d t = showParen (d > cons_prec) $ showMany t - where - cons_prec = 5 -- infixr 5 cons +-- | Two 'Many's are equal if all their fields equal +instance Show (Many_ xs) => Show (Many xs) where + showsPrec d xs = showsPrec d (toMany_ xs) ----------------------------------------------------------------------- -newtype EmitReadMany (xs :: [Type]) r = EmitReadMany Key - -instance Reiterate EmitReadMany (x ': xs) where - reiterate (EmitReadMany (Key i)) = EmitReadMany (Key (i + 1)) - -instance Emit EmitReadMany '[] (ReadPrec [(Key, WrappedAny)]) where - emit (EmitReadMany _) = do - lift $ L.expect (Ident "nul") - pure [] +instance Read (Many_ '[]) where + readPrec = parens $ prec app_prec $ do + lift $ L.expect (Ident "nil") + pure $ Many_ [] + where + app_prec = 10 -instance Read x => Emit EmitReadMany (x ': xs) (ReadPrec [(Key, WrappedAny)]) where - emit (EmitReadMany i) = do - a <- readPrec @x +instance (Read x, Read (Many_ xs)) => Read (Many_ (x ': xs)) where + readPrec = parens $ prec cons_prec $ do + a <- step (readPrec @x) lift $ L.expect (Symbol "./") - pure [(i, WrappedAny (unsafeCoerce a))] - -readMany - :: forall xs. - AFoldable (Collector0 EmitReadMany xs) (ReadPrec [(Key, WrappedAny)]) - => Proxy (xs :: [Type]) -> ReadPrec [(Key, WrappedAny)] -readMany _ = afoldr (liftA2 (++)) (pure []) (Collector0 (EmitReadMany @xs (Key 0))) + as <- readPrec @(Many_ xs) -- no 'step' to allow right associatitive './' + pure $ prefix' a as + where + cons_prec = 5 -- infixr `prefix` + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE readPrec #-} --- | @read "5 ./ False ./ 'X' ./ Just 'O' ./ nul" == (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nul'@ -instance (AFoldable (Collector0 EmitReadMany xs) (ReadPrec [(Key, WrappedAny)])) => - Read (Many xs) where - readPrec = - parens $ - prec 10 $ do - xs <- readMany @xs Proxy - pure (Many 0 (fromList' xs)) +-- | @read "5 ./ False ./ 'X' ./ Just 'O' ./ nil" == (5 :: Int) './' False './' \'X' './' Just \'O' './' 'nil'@ +instance Read (Many_ xs) => Read (Many xs) where + readPrec = do + xs <- readPrec @(Many_ xs) + pure $ fromMany_ xs -- | 'WrappedAny' avoids the following: -- Illegal type synonym family application in instance: Any diff --git a/src/Data/Diverse/Type.hs b/src/Data/Diverse/Type.hs --- a/src/Data/Diverse/Type.hs +++ b/src/Data/Diverse/Type.hs @@ -16,8 +16,14 @@ -- | Ensures that @x@ is a unique member of @xs@, and that 'natVal' can be used. type UniqueMember x xs = (Unique x xs, KnownNat (IndexOf x xs)) +-- | Ensures that @x@ is a unique member of @xs@, and that 'natVal' can be used. +type UniqueMemberAt n x xs = (Unique x xs, KnownNat n, n ~ IndexOf x xs) + +-- | Ensures that @x@ is a unique member of @xs@, and that 'natVal' can be used. +type UniqueLabelMember l xs = (UniqueLabel l xs, KnownNat (IndexOf (KindAtLabel l xs) xs)) + -- | Ensures that @x@ is a unique member of @xs@ if it exists, and that 'natVal' can be used. -type MaybeUniqueMember x xs = (Unique x xs, KnownNat (PositionOf x xs)) +type MaybeUniqueMemberAt n x xs = (Unique x xs, KnownNat n, n ~ PositionOf x xs) -- | Ensures that @x@ is a member of @xs@ at @n@, and that 'natVal' can be used. type MemberAt n x xs = (KnownNat n, x ~ KindAtIndex n xs) @@ -42,6 +48,14 @@ -- | Ensures that @x@ only ever appears once in @xs@ type Unique (x :: k) (xs :: [k]) = UniqueImpl xs x xs +-- | Ensures that the @label@ in @tagged label v@ only ever appears once in @xs@. +type UniqueLabel (l :: k1) (xs :: [k]) = UniqueLabelImpl xs l xs + +-- | Ensures that the @label@ list all 'UniqueLabel's +type family UniqueLabels (ls :: [k1]) (xs :: [k]) :: Constraint where + UniqueLabels '[] xs = () + UniqueLabels (l ': ls) xs = (UniqueLabel l xs, UniqueLabels ls xs) + -- | Get the first index of a type (Indexed by 0) -- Will result in type error if x doesn't exist in xs. type IndexOf (x :: k) (xs :: [k]) = IndexOfImpl xs x xs @@ -54,7 +68,7 @@ type KindAtIndex (n :: Nat) (xs :: [k]) = KindAtIndexImpl n xs n xs -- | Get the type at a label -type KindAtLabel (l :: k1) (xs :: [k2]) = KindAtLabelImpl l xs xs +type KindAtLabel (l :: k1) (xs :: [k]) = KindAtLabelImpl l xs xs -- | It's actually ok for the position to be zero, but if it's not zero then the types must match type family KindAtPositionIs (n :: Nat) (x :: k) (xs :: [k]) :: Constraint where @@ -65,6 +79,10 @@ type family KindsAtIndices (ns :: [Nat]) (xs :: [k]) :: [k] where KindsAtIndices '[] xs = '[] KindsAtIndices (n ': ns) xs = KindAtIndex n xs ': KindsAtIndices ns xs + +type family KindsAtLabels (ls :: [k1]) (xs :: [k]) :: [k] where + KindsAtLabels '[] xs = '[] + KindsAtLabels (l ': ls) xs = KindAtLabel l xs ': KindsAtLabels ls xs -- | The typelist @xs@ without first @x@. It is okay for @x@ not to exist in @xs@ type family Without (x :: k) (xs :: [k]) :: [k] where diff --git a/src/Data/Diverse/Type/Internal.hs b/src/Data/Diverse/Type/Internal.hs --- a/src/Data/Diverse/Type/Internal.hs +++ b/src/Data/Diverse/Type/Internal.hs @@ -41,7 +41,7 @@ -- | Errors if a type exists in a typelist type family MissingImpl (ctx :: [k]) (y :: k) (xs :: [k]) :: Constraint where MissingImpl ctx y '[] = () - MissingImpl ctx x (x ': xs) = TypeError ('Text "Missing error: ‘" + MissingImpl ctx x (x ': xs) = TypeError ('Text "Not unique error: ‘" ':<>: 'ShowType x ':<>: 'Text "’" ':<>: 'Text " is a duplicate in " @@ -50,7 +50,20 @@ ':<>: 'Text "’") MissingImpl ctx y (x ': xs) = (MissingImpl ctx y xs) --- | Ensures that the type list contain unique types +-- | Errors if a label exists in a typelist +type family MissingLabelImpl (ctx :: [k]) (l :: k2) (xs :: [k]) :: Constraint where + MissingLabelImpl ctx y '[] = () + MissingLabelImpl ctx l (tagged l x ': xs) = TypeError ('Text "Not unique label error: ‘" + ':<>: 'ShowType l + ':<>: 'Text "’" + ':<>: 'Text " is a duplicate in " + ':<>: 'Text "‘" + ':<>: 'ShowType ctx + ':<>: 'Text "’") + MissingLabelImpl ctx l (x ': xs) = (MissingLabelImpl ctx l xs) + +-- | Ensures that the type list contain unique types. +-- Not implemented as @(xs ~ Nub xs)@ for better type error messages. type family IsDistinctImpl (ctx :: [k]) (xs :: [k]) :: Constraint where IsDistinctImpl ctx '[] = () IsDistinctImpl ctx (x ': xs) = (MissingImpl ctx x xs, IsDistinctImpl ctx xs) @@ -61,6 +74,12 @@ UniqueImpl ctx x (x ': xs) = MissingImpl ctx x xs UniqueImpl ctx x (y ': xs) = UniqueImpl ctx x xs +-- | Ensures that the @label@ in @tagged label v@ only ever appears once in @xs@. +type family UniqueLabelImpl (ctx :: [k]) (l :: k1) (xs :: [k]) :: Constraint where + UniqueLabelImpl ctx l '[] = () + UniqueLabelImpl ctx l (tagged l x ': xs) = MissingLabelImpl ctx l xs + UniqueLabelImpl ctx l (y ': xs) = UniqueLabelImpl ctx l xs + -- | Indexed access into the list type family KindAtIndexImpl (orig :: Nat) (ctx :: [k]) (n :: Nat) (xs :: [k]) :: k where KindAtIndexImpl i ctx 0 '[] = TypeError ('Text "KindAtIndex error: Index ‘" @@ -74,7 +93,7 @@ KindAtIndexImpl i ctx n (x ': xs) = KindAtIndexImpl i ctx (n - 1) xs -- | Labelled access into the list -type family KindAtLabelImpl (l :: k1) (ctx :: [k2]) (xs :: [k2]) :: k2 where +type family KindAtLabelImpl (l :: k1) (ctx :: [k]) (xs :: [k]) :: k where KindAtLabelImpl l ctx '[] = TypeError ('Text "KindAtLabel error: Label ‘" ':<>: 'ShowType l ':<>: 'Text "’" diff --git a/src/Data/Diverse/Which.hs b/src/Data/Diverse/Which.hs --- a/src/Data/Diverse/Which.hs +++ b/src/Data/Diverse/Which.hs @@ -9,14 +9,17 @@ , pick , pick0 , pickOnly + , pickL , pickN -- ** Destruction , obvious , trial , trial0 + , trialL , trialN -- ** Lens , facet + , facetL , facetN -- * Multiple types @@ -24,15 +27,18 @@ , Diversify , diversify , diversify0 + , diversifyL , DiversifyN , diversifyN -- ** Inverse Injection , Reinterpret , reinterpret + , reinterpretL , ReinterpretN , reinterpretN -- ** Lens , inject + , injectL , injectN -- * Catamorphism diff --git a/src/Data/Diverse/Which/Internal.hs b/src/Data/Diverse/Which/Internal.hs --- a/src/Data/Diverse/Which/Internal.hs +++ b/src/Data/Diverse/Which/Internal.hs @@ -23,14 +23,17 @@ , pick , pick0 , pickOnly + , pickL , pickN -- ** Destruction , obvious , trial , trial0 + , trialL , trialN -- ** Lens , facet + , facetL , facetN -- * Multiple types @@ -38,15 +41,18 @@ , Diversify , diversify , diversify0 + , diversifyL , DiversifyN , diversifyN -- ** Inverse Injection , Reinterpret , reinterpret + , reinterpretL , ReinterpretN , reinterpretN -- ** Lens , inject + , injectL , injectN -- * Catamorphism @@ -60,17 +66,15 @@ import Control.Applicative import Control.Lens -import Data.Diverse.AFoldable +import Control.Monad import Data.Diverse.Case -import Data.Diverse.Collector -import Data.Diverse.Emit import Data.Diverse.Reduce import Data.Diverse.Reiterate import Data.Diverse.Type import Data.Kind import Data.Proxy import qualified GHC.Generics as G -import GHC.Prim (Any) +import GHC.Prim (Any, coerce) import GHC.TypeLits import Text.ParserCombinators.ReadPrec import Text.Read @@ -105,6 +109,10 @@ data Which (xs :: [Type]) = Which {-# UNPACK #-} !Int Any -- Just like Haskus and HList versions, inferred type is phantom which is wrong +-- representational means: +-- @ +-- Coercible '[Int] '[IntLike] => Coercible (Which '[Int]) (Which '[IntLike]) +-- @ type role Which representational ---------------------------------------------- @@ -151,8 +159,21 @@ -- 'pick' \'A' \@'[Int, Bool, Char, Maybe String] :: Which '[Int, Bool, Char, Maybe String] -- @ pick :: forall xs x. UniqueMember x xs => x -> Which xs -pick = Which (fromInteger (natVal @(IndexOf x xs) Proxy)) . unsafeCoerce +pick = pick_ +pick_ :: forall x xs n. (KnownNat n, n ~ IndexOf x xs) => x -> Which xs +pick_ = Which (fromInteger (natVal @n Proxy)) . unsafeCoerce + +-- | A variation of 'pick' where @x@ is specified via a label +-- +-- @ +-- let y = 'pickL' \@Foo Proxy (Tagged (5 :: Int)) :: Which '[Bool, Tagged Foo Int, Tagged Bar Char] +-- x = 'trialL' \@Foo Proxy y +-- x `shouldBe` (Right (Tagged 5)) +-- @ +pickL :: forall l xs x proxy. (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => proxy l -> x -> Which xs +pickL _ = pick_ @x + -- | A variation of 'pick' into a 'Which' of a single type. -- -- @ @@ -197,13 +218,32 @@ :: forall x xs. (UniqueMember x xs) => Which xs -> Either (Which (Without x xs)) x -trial (Which n v) = let i = fromInteger (natVal @(IndexOf x xs) Proxy) +trial = trial_ + +trial_ + :: forall x xs n. + (KnownNat n, n ~ IndexOf x xs) + => Which xs -> Either (Which (Without x xs)) x +trial_ (Which n v) = let i = fromInteger (natVal @n Proxy) in if n == i then Right (unsafeCoerce v) else if n > i then Left (Which (n - 1) v) else Left (Which n v) +-- | A variation of 'trial' where x is specified via a label +-- +-- @ +-- let y = 'pickL' \@Foo Proxy (Tagged (5 :: Int)) :: Which '[Bool, Tagged Foo Int, Tagged Bar Char] +-- x = 'trialL' \@Foo Proxy y +-- x `shouldBe` (Right (Tagged 5)) +-- @ +trialL + :: forall l xs x proxy. + (UniqueLabelMember l xs, x ~ KindAtLabel l xs) + => proxy l -> Which xs -> Either (Which (Without x xs)) x +trialL _ = trial_ @x + -- | A variation of a 'Which' 'trial' which 'trial's the first type in the type list. -- -- @ @@ -215,7 +255,6 @@ then Right (unsafeCoerce v) else Left (Which (n - 1) v) - -- | 'trialN' the n-th type of a 'Which', and get 'Either' the 'Right' value or the 'Left'-over possibilities. -- -- @ @@ -254,6 +293,17 @@ facet = prism' pick (hush . trial) {-# INLINE facet #-} +-- | '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 +-- x \`shouldBe` (Just (Tagged 5)) +-- @ +facetL :: forall l xs x proxy. (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => proxy l -> Prism' (Which xs) x +facetL p = prism' (pickL p) (hush . trialL p) +{-# INLINE facetL #-} + -- | 'pickN' ('review' 'facetN') and 'trialN' ('preview' 'facetN') in 'Prism'' form. -- -- @ @@ -307,10 +357,30 @@ ------------------------------------------------------------------ +-- | A variation of 'diversify' where @branch@is additionally specified by a labels list. +-- +-- @ +-- let y = 'pickOnly' (5 :: Tagged Bar Int) +-- y' = 'diversifyL' \@'[Bar] Proxy y :: 'Which' '[Tagged Bar Int, Tagged Foo Bool] +-- y'' = 'diversifyL' \@'[Bar, Foo] Proxy y' :: 'Which' '[Tagged Foo Bool, Tagged Bar Int] +-- 'switch' y'' ('Data.Diverse.CaseTypeable.CaseTypeable' (show . typeRep . (pure \@Proxy))) \`shouldBe` \"Tagged * Bar Int" +-- @ +diversifyL + :: forall ls tree branch proxy. + ( Diversify tree branch + , branch ~ KindsAtLabels ls tree + , UniqueLabels ls tree + , IsDistinct ls + ) + => proxy ls -> Which branch -> Which tree +diversifyL _ = which (CaseDiversify @tree @branch @branch) + +------------------------------------------------------------------ + -- | A friendlier constraint synonym for 'diversifyN'. type DiversifyN (indices :: [Nat]) (tree :: [Type]) (branch :: [Type]) = (Reduce Which (SwitchN (CaseDiversifyN indices) 0) (KindsAtIndices indices tree) (Which tree), KindsAtIndices indices tree ~ branch) --- | A variation of 'diversify' which uses a Nat list @n@ to specify how to reorder the fields, where +-- | A variation of 'diversify' which uses a Nat list @indices@ to specify how to reorder the fields, where -- -- @ -- indices[branch_idx] = tree_idx @@ -364,21 +434,43 @@ instance Reiterate (CaseReinterpret branch tree) tree' where reiterate CaseReinterpret = CaseReinterpret -instance ( MaybeUniqueMember x branch +instance ( MaybeUniqueMemberAt n x branch , comp ~ Complement tree branch - , MaybeUniqueMember x comp + , MaybeUniqueMemberAt n' x comp , Unique x tree -- Compile error to ensure reinterpret only works with unique fields ) => Case (CaseReinterpret branch tree) (x ': tree') (Either (Which comp) (Which branch)) where case' CaseReinterpret a = - case fromInteger (natVal @(PositionOf x branch) Proxy) of - 0 -> let j = fromInteger (natVal @(PositionOf x (Complement tree branch)) Proxy) + case fromInteger (natVal @n Proxy) of + 0 -> let j = fromInteger (natVal @n' Proxy) -- safe use of partial! j will never be zero due to check above in Left $ Which (j - 1) (unsafeCoerce a) i -> Right $ Which (i - 1) (unsafeCoerce a) ------------------------------------------------------------------ +-- | A variation of 'reinterpret' where the @branch@ is additionally specified with a labels list. +-- +-- @ +-- let y = 'pick' \@[Tagged Bar Int, Tagged Foo Bool, Tagged Hi Char, Tagged Bye Bool] (5 :: Tagged Bar Int) +-- y' = 'reinterpretL' \@[Foo, Bar] Proxy y +-- x = 'pick' \@[Tagged Foo Bool, Tagged Bar Int] (5 :: Tagged Bar Int) +-- y' \`shouldBe` Right x +-- @ +reinterpretL + :: forall ls branch tree proxy. + ( Reinterpret branch tree + , branch ~ KindsAtLabels ls tree + , UniqueLabels ls tree + , IsDistinct ls + ) + => proxy ls + -> Which tree + -> Either (Which (Complement tree branch)) (Which branch) +reinterpretL _ = which (CaseReinterpret @branch @tree @tree) + +------------------------------------------------------------------ + -- | A friendlier constraint synonym for 'reinterpretN'. type ReinterpretN (indices :: [Nat]) (branch :: [Type]) (tree :: [Type]) = (Reduce Which (SwitchN (CaseReinterpretN indices) 0) tree (Maybe (Which (KindsAtIndices indices tree))), KindsAtIndices indices tree ~ branch) @@ -404,9 +496,9 @@ instance ReiterateN (CaseReinterpretN indices) n tree' where reiterateN CaseReinterpretN = CaseReinterpretN -instance MaybeMemberAt (PositionOf n indices) x branch => Case (CaseReinterpretN indices n) (x ': tree) (Maybe (Which branch)) where +instance (MaybeMemberAt n' x branch, n' ~ PositionOf n indices) => Case (CaseReinterpretN indices n) (x ': tree) (Maybe (Which branch)) where case' CaseReinterpretN a = - case fromInteger (natVal @(PositionOf n indices) Proxy) of + case fromInteger (natVal @n' Proxy) of 0 -> Nothing i -> Just $ Which (i - 1) (unsafeCoerce a) @@ -430,6 +522,29 @@ inject = prism' diversify (hush . reinterpret) {-# INLINE inject #-} + +-- | '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 \`shouldBe` t' +-- b' \`shouldBe` Just b +-- @ +injectL + :: forall ls branch tree proxy. + ( Diversify tree branch + , Reinterpret branch tree + , branch ~ KindsAtLabels ls tree + , UniqueLabels ls tree + , IsDistinct ls + ) + => proxy ls -> Prism' (Which tree) (Which branch) +injectL p = prism' (diversifyL p) (hush . reinterpretL p) +{-# INLINE injectL #-} + -- | 'diversifyN' ('review' 'injectN') and 'reinterpretN' ('preview' 'injectN') in 'Prism'' form. -- -- @ @@ -456,15 +571,14 @@ -- | 'trial0' each type in a 'Which', and either handle the 'case'' with value discovered, or __'reiterate'__ -- trying the next type in the type list. --- This code will be efficiently compiled into a single case statement in GHC 8.2.1 --- See http://hsyl20.fr/home/posts/2016-12-12-control-flow-in-haskell-part-2.html instance (Case c (x ': x' ': xs) r, Reduce Which (Switch c) (x' ': xs) r, Reiterate c (x : x' : xs)) => Reduce Which (Switch c) (x ': x' ': xs) r where reduce (Switch c) v = case trial0 v of Right a -> case' c a Left v' -> reduce (Switch (reiterate c)) v' - {-# INLINE reduce #-} + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE reduce #-} -- | Terminating case of the loop, ensuring that a instance of @Case '[]@ -- with an empty typelist is not required. @@ -486,7 +600,7 @@ -- 'Data.Diverse.Which.switch' y ( -- 'Data.Diverse.Cases.cases' (show \@Bool -- 'Data.Diverse.Many../' show \@Int --- 'Data.Diverse.Many../' 'Data.Diverse.Many.nul')) \`shouldBe` "5" +-- 'Data.Diverse.Many../' 'Data.Diverse.Many.nil')) \`shouldBe` "5" -- @ -- -- Or 'Data.Diverse.CaseTypeable.CaseTypeable' to apply a polymorphic function that work on all 'Typeables'. @@ -508,15 +622,14 @@ -- | 'trial0' each type in a 'Which', and either handle the 'case'' with value discovered, or __'reiterateN'__ -- trying the next type in the type list. --- This code will be efficiently compiled into a single case statement in GHC 8.2.1 --- See http://hsyl20.fr/home/posts/2016-12-12-control-flow-in-haskell-part-2.html instance (Case (c n) (x ': x' ': xs) r, Reduce Which (SwitchN c (n + 1)) (x' ': xs) r, ReiterateN c n (x : x' : xs)) => Reduce Which (SwitchN c n) (x ': x' ': xs) r where reduce (SwitchN c) v = case trial0 v of Right a -> case' c a Left v' -> reduce (SwitchN (reiterateN c)) v' - {-# INLINE reduce #-} + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE reduce #-} -- | Terminating case of the loop, ensuring that a instance of @Case '[]@ -- with an empty typelist is not required. @@ -541,7 +654,7 @@ -- 'Data.Diverse.Many../' show \@Bool -- 'Data.Diverse.Many../' show \@Bool -- 'Data.Diverse.Many../' show \@Int --- 'Data.Diverse.Many../' 'Data.Diverse.Many.nul')) \`shouldBe` "5" +-- 'Data.Diverse.Many../' 'Data.Diverse.Many.nil')) \`shouldBe` "5" -- @ -- -- Or you may use your own custom instance of 'Case'. @@ -598,7 +711,7 @@ -- | @show ('pick'' \'A') == "pick \'A'"@ instance (Reduce Which (Switch CaseShowWhich) (x ': xs) ShowS) => Show (Which (x ': xs)) where - showsPrec d v = showParen (d > app_prec) ((showString "pick ") . (which CaseShowWhich v)) + showsPrec d v = showParen (d > app_prec) (which (CaseShowWhich 0) v) where app_prec = 10 -- | @read "impossible" == 'impossible'@ @@ -606,49 +719,59 @@ showsPrec d _ = showParen (d > app_prec) (showString "impossible") where app_prec = 10 -data CaseShowWhich (xs :: [Type]) r = CaseShowWhich +newtype CaseShowWhich (xs :: [Type]) r = CaseShowWhich Int instance Reiterate CaseShowWhich (x ': xs) where - reiterate CaseShowWhich = CaseShowWhich + reiterate (CaseShowWhich i) = CaseShowWhich (i + 1) instance Show x => Case CaseShowWhich (x ': xs) ShowS where - case' _ = showsPrec (app_prec + 1) + case' (CaseShowWhich i) v = showString "pickN @" . showString (show i) . showString " Proxy " . showsPrec (app_prec + 1) v where app_prec = 10 ------------------------------------------------------------------ -newtype EmitReadWhich (xs :: [Type]) r = EmitReadWhich Int +class WhichRead v where + whichReadPrec :: Int -> Int -> ReadPrec v -instance Reiterate EmitReadWhich (x ': xs) where - reiterate (EmitReadWhich i) = EmitReadWhich (i + 1) +data Which_ (xs ::[Type]) = Which_ Int Any -instance Read x => Emit EmitReadWhich (x ': xs) (ReadPrec (Int, WrappedAny)) where - emit (EmitReadWhich i) = (\a -> (i, WrappedAny (unsafeCoerce a))) <$> readPrec @x +diversify0' :: forall x xs. Which_ xs -> Which_ (x ': xs) +diversify0' = coerce -readWhich - :: forall xs. - AFoldable (Collector EmitReadWhich xs) (ReadPrec (Int, WrappedAny)) - => Proxy (xs :: [Type]) -> ReadPrec (Int, WrappedAny) -readWhich _ = afoldr (<|>) empty (Collector (EmitReadWhich @xs 0)) +readWhich_ :: forall x xs. Read x => Int -> Int -> ReadPrec (Which_ (x ': xs)) +readWhich_ i j = guard (i == j) >> parens (prec app_prec $ (Which_ i . unsafeCoerce) <$> readPrec @x) + where + app_prec = 10 +instance Read x => WhichRead (Which_ '[x]) where + whichReadPrec = readWhich_ + +instance (Read x, WhichRead (Which_ (x' ': xs))) => WhichRead (Which_ (x ': x' ': xs)) where + whichReadPrec i j = readWhich_ i j + <|> (diversify0' <$> (whichReadPrec i (j + 1) :: ReadPrec (Which_ (x' ': xs)))) + -- GHC compilation is SLOW if there is no pragma for recursive typeclass functions for different types + {-# NOINLINE whichReadPrec #-} + + -- | This 'Read' instance tries to read using the each type in the typelist, using the first successful type read. -instance AFoldable (Collector EmitReadWhich (x ': xs)) (ReadPrec (Int, WrappedAny)) => +instance WhichRead (Which_ (x ': xs)) => Read (Which (x ': xs)) where readPrec = - parens $ - prec 10 $ do - lift $ L.expect (Ident "pick") - (n, WrappedAny v) <- step (readWhich @(x ': xs) Proxy) - pure (Which n v) + parens $ prec app_prec $ do + lift $ L.expect (Ident "pickN") + lift $ L.expect (Punc "@") + i <- lift L.readDecP + lift $ L.expect (Ident "Proxy") + Which_ n v <- whichReadPrec i 0 :: ReadPrec (Which_ (x ': xs)) + pure $ Which n v + where + app_prec = 10 -- | @read "impossible" == 'impossible'@ instance Read (Which '[]) where readPrec = - parens $ - prec 10 $ do + parens $ prec app_prec $ do lift $ L.expect (Ident "impossible") pure impossible - --- | 'WrappedAny' avoids the following: --- Illegal type synonym family application in instance: Any -newtype WrappedAny = WrappedAny Any + where + app_prec = 10 diff --git a/test/Data/Diverse/ManySpec.hs b/test/Data/Diverse/ManySpec.hs --- a/test/Data/Diverse/ManySpec.hs +++ b/test/Data/Diverse/ManySpec.hs @@ -10,8 +10,8 @@ import Control.Lens import Data.Diverse -import Data.Typeable import Data.Tagged +import Data.Typeable import Test.Hspec -- `main` is here so that this module can be run from GHCi on its own. It is @@ -26,7 +26,7 @@ spec = do describe "Many" $ do it "is a Typeable" $ do - let x = (5 :: Int) ./ False ./ nul + let x = (5 :: Int) ./ False ./ nil y = cast x :: Maybe (Many '[Int, String]) z = cast x :: Maybe (Many '[Int, Bool]) y `shouldBe` Nothing @@ -34,22 +34,25 @@ (show . typeRep . (pure @Proxy) $ x) `shouldBe` "Many (': * Int (': * Bool '[]))" it "is a Read and Show" $ do - let s = "5 ./ False ./ 'X' ./ Just 'O' ./ nul" + let s = "5 ./ False ./ 'X' ./ Just 'O' ./ nil" + s' = "5 ./ False ./ 'X' ./ (Just 'O' ./ (nil))" x = read s :: Many '[Int, Bool, Char, Maybe Char] + x' = read s' :: Many '[Int, Bool, Char, Maybe Char] show x `shouldBe` s + show x' `shouldBe` s it "is a Eq" $ do - let s = "5 ./ False ./ 'X' ./ Just 'O' ./ nul" + let s = "5 ./ False ./ 'X' ./ Just 'O' ./ nil" x = read s :: Many '[Int, Bool, Char, Maybe Char] - y = 5 ./ False ./ 'X' ./ Just 'O' ./ nul + y = 5 ./ False ./ 'X' ./ Just 'O' ./ nil x `shouldBe` y it "is an Ord" $ do - let s = "5 ./ False ./ 'X' ./ Just 'O' ./ nul" + let s = "5 ./ False ./ 'X' ./ Just 'O' ./ nil" x = read s :: Many '[Int, Bool, Char, Maybe Char] - y5o = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - y4o = (4 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - y5p = (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nul + y5o = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + y4o = (4 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + y5p = (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nil compare x y5o `shouldBe` EQ compare y4o y5o `shouldBe` LT compare y5o y4o `shouldBe` GT @@ -57,16 +60,16 @@ compare y5p y5o `shouldBe` GT it "can converted to and from a tuple" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil t = ((5 :: Int), False, 'X', Just 'O') x `shouldBe` toMany' t x `shouldBe` review _Many' t t `shouldBe` fromMany' x t `shouldBe` view _Many' x - it "can construct using 'single', 'nul', 'prefix', 'postfix', 'append'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - x' = (5 :: Int) `prefix` False `prefix` 'X' `prefix` Just 'O' `prefix` nul + it "can construct using 'single', 'nil', 'prefix', 'postfix', 'append'" $ do + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + x' = (5 :: Int) `prefix` False `prefix` 'X' `prefix` Just 'O' `prefix` nil y = single (5 :: Int) \. False \. 'X' \. Just 'O' y' = single (5 :: Int) `postfix` False `postfix` 'X' `postfix` Just 'O' a = single (5 :: Int) `postfix` False @@ -78,14 +81,14 @@ a `append` b `shouldBe` x it "can contain multiple fields of the same type" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - (x /./ (6 :: Int) ./ Just 'A' ./ nul) `shouldBe` y + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + (x /./ (6 :: Int) ./ Just 'A' ./ nil) `shouldBe` y it "can destruct using 'front', 'back', 'aft', 'fore'" $ do let a = (x ./ y) \. z x = 5 :: Int - y = single False ./ 'X' ./ nul + y = single False ./ 'X' ./ nil z = Just 'O' front a `shouldBe` x back a `shouldBe` z @@ -93,21 +96,21 @@ fore a `shouldBe` x ./ y it "has getter for unique fields using 'fetch'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil fetch @Int x `shouldBe` 5 fetch @Bool x `shouldBe` False fetch @Char x `shouldBe` 'X' fetch @(Maybe Char) x `shouldBe` Just 'O' it "has getter for for unique fields using 'fetchN'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil fetchN @0 Proxy x `shouldBe` 5 fetchN @1 Proxy x `shouldBe` False fetchN @2 Proxy x `shouldBe` 'X' fetchN @3 Proxy x `shouldBe` Just 'O' it "has getter for duplicate fields using 'fetchN'" $ do - let y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + let y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil fetchN @0 Proxy y `shouldBe` 5 fetchN @1 Proxy y `shouldBe` False fetchN @2 Proxy y `shouldBe` 'X' @@ -116,213 +119,264 @@ fetchN @5 Proxy y `shouldBe` Just 'A' it "with duplicate fields can still use 'fetch' for unique fields" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil fetch @Bool x `shouldBe` False fetch @Char x `shouldBe` 'X' - it "can 'fetch' usng tagged labels" $ do - let y = (5 :: Int) ./ False ./ Tagged @Foo 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + it "has getter for unique labels using 'fetchL'" $ do + let y = (5 :: Int) ./ False ./ Tagged @Foo 'X' ./ Tagged @"Hello" (6 :: Int) ./ nil fetch @(Tagged Foo _) y `shouldBe` Tagged @Foo 'X' + fetchL @Foo Proxy y `shouldBe` Tagged @Foo 'X' + fetchL @"Hello" Proxy y `shouldBe` Tagged @"Hello" (6 :: Int) it "has setter for unique fields using 'replace'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - replace @Int x 6 `shouldBe` (6 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - replace x True `shouldBe` (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ nul - replace x 'O' `shouldBe` (5 :: Int) ./ False ./ 'O' ./ Just 'O' ./ nul - replace x (Just 'P') `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + replace @Int x 6 `shouldBe` (6 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + replace x True `shouldBe` (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ nil + replace x 'O' `shouldBe` (5 :: Int) ./ False ./ 'O' ./ Just 'O' ./ nil + replace x (Just 'P') `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nil it "has polymorphic setter for unique fields using 'replace'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - replace' @Int Proxy x 'Z' `shouldBe` 'Z' ./ False ./ 'X' ./ Just 'O' ./ nul - replace' @Bool Proxy x 'Z' `shouldBe` (5 :: Int) ./ 'Z' ./ 'X' ./ Just 'O' ./ nul - replace' @(Maybe Char) Proxy x 'Z' `shouldBe` (5 :: Int) ./ False ./ 'X' ./ 'Z' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + replace' @Int Proxy x 'Z' `shouldBe` 'Z' ./ False ./ 'X' ./ Just 'O' ./ nil + replace' @Bool Proxy x 'Z' `shouldBe` (5 :: Int) ./ 'Z' ./ 'X' ./ Just 'O' ./ nil + replace' @(Maybe Char) Proxy x 'Z' `shouldBe` (5 :: Int) ./ False ./ 'X' ./ 'Z' ./ nil + it "has setter for unique labels using 'replaceL'" $ do + let y = (5 :: Int) ./ False ./ Tagged @Foo 'X' ./ Tagged @"Hello" (6 :: Int) ./ nil + replace @(Tagged Foo _) y (Tagged @Foo 'Y') `shouldBe` + (5 :: Int) ./ False ./ Tagged @Foo 'Y' ./ Tagged @"Hello" (6 :: Int) ./ nil + replaceL @Foo Proxy y (Tagged @Foo 'Y') `shouldBe` + (5 :: Int) ./ False ./ Tagged @Foo 'Y' ./ Tagged @"Hello" (6 :: Int) ./ nil + replaceL @"Hello" Proxy y (Tagged @"Hello" 7) `shouldBe` + (5 :: Int) ./ False ./ Tagged @Foo 'X' ./ Tagged @"Hello" (7 :: Int) ./ nil + + it "has polymorphic setter for unique labels using 'replaceL'" $ do + let y = (5 :: Int) ./ False ./ Tagged @Foo 'X' ./ Tagged @"Hello" (6 :: Int) ./ nil + replace' @(Tagged Foo Char) Proxy y (Tagged @Bar 'Y') `shouldBe` + (5 :: Int) ./ False ./ Tagged @Bar 'Y' ./ Tagged @"Hello" (6 :: Int) ./ nil + replaceL' @Foo Proxy y (Tagged @Bar 'Y') `shouldBe` + (5 :: Int) ./ False ./ Tagged @Bar 'Y' ./ Tagged @"Hello" (6 :: Int) ./ nil + replaceL' @"Hello" Proxy y (Tagged @"Hello" False) `shouldBe` + (5 :: Int) ./ False ./ Tagged @Foo 'X' ./ Tagged @"Hello" False ./ nil + it "has setter for unique fields using 'replaceN'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil replaceN @0 Proxy x (7 :: Int) `shouldBe` - (7 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul + (7 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil replaceN @1 Proxy x True `shouldBe` - (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ nul + (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ nil replaceN @2 Proxy x 'Y' `shouldBe` - (5 :: Int) ./ False ./ 'Y' ./ Just 'O' ./ nul + (5 :: Int) ./ False ./ 'Y' ./ Just 'O' ./ nil replaceN @3 Proxy x (Just 'P') `shouldBe` - (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nul + (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nil it "has polymorphic setter using 'replaceN''" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil replaceN' @0 Proxy x True `shouldBe` - True ./ False ./ 'X' ./ Just 'O' ./ nul - let y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + True ./ False ./ 'X' ./ Just 'O' ./ nil + let y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil replaceN' @1 Proxy y 'Y' `shouldBe` - (5 :: Int) ./ 'Y' ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + (5 :: Int) ./ 'Y' ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil replaceN' @5 Proxy y 'Y' `shouldBe` - (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ 'Y' ./ nul + (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ 'Y' ./ nil it "has setter for duplicate fields using 'replaceN'" $ do - let y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + let y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil replaceN @0 Proxy y (7 :: Int) `shouldBe` - (7 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + (7 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil replaceN @1 Proxy y True `shouldBe` - (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil replaceN @2 Proxy y 'Y' `shouldBe` - (5 :: Int) ./ False ./ 'Y' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + (5 :: Int) ./ False ./ 'Y' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil replaceN @3 Proxy y (Just 'P') `shouldBe` - (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ (6 :: Int) ./ Just 'A' ./ nul + (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ (6 :: Int) ./ Just 'A' ./ nil replaceN @4 Proxy y (8 :: Int) `shouldBe` - (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (8 :: Int) ./ Just 'A' ./ nul + (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (8 :: Int) ./ Just 'A' ./ nil replaceN @5 Proxy y (Just 'B') `shouldBe` - (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'B' ./ nul + (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'B' ./ nil it "has setter for unique fields using 'replace' (even if there are other duplicate fields)" $ do - let y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + let y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil replace @Bool y True `shouldBe` - (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil replace @Char y 'Y' `shouldBe` - (5 :: Int) ./ False ./ 'Y' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - - it "can 'replace' usng tagged labels" $ do - let y = (5 :: Int) ./ False ./ Tagged @Foo 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - replace @(Tagged Foo _) y (Tagged @Foo 'Y') `shouldBe` - (5 :: Int) ./ False ./ Tagged @Foo 'Y' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - - it "can 'replace'' polymorphically usng tagged labels" $ do - let y = (5 :: Int) ./ False ./ Tagged @Foo 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - replace' @(Tagged Foo Char) Proxy y (Tagged @Bar 'Y') `shouldBe` - (5 :: Int) ./ False ./ Tagged @Bar 'Y' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + (5 :: Int) ./ False ./ 'Y' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil it "has getter/setter lens using 'item'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil x ^. item @Int `shouldBe` 5 - (x & item @Int .~ 6) `shouldBe` (6 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul + (x & item @Int .~ 6) `shouldBe` (6 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil x ^. item @Bool `shouldBe` False - (x & item @Bool .~ True) `shouldBe` (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ nul + (x & item @Bool .~ True) `shouldBe` (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ nil x ^. item @Char `shouldBe` 'X' x ^. item @(Maybe Char) `shouldBe` Just 'O' it "has polymorphic getter/setter lens using 'item''" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - (x & item' @(Maybe Char) .~ Just 'P') `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nul - (x & item' @Int .~ 'Z') `shouldBe` 'Z' ./ False ./ 'X' ./ Just 'O' ./ nul - (x & item' @Bool .~ 'Z') `shouldBe` (5 :: Int) ./ 'Z' ./ 'X' ./ Just 'O' ./ nul - (x & item' @Char .~ True) `shouldBe` (5 :: Int) ./ False ./ True ./ Just 'O' ./ nul - (x & item' @(Maybe Char) .~ 'P') `shouldBe` (5 :: Int) ./ False ./ 'X' ./ 'P' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + (x & item' @(Maybe Char) .~ Just 'P') `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nil + (x & item' @Int .~ 'Z') `shouldBe` 'Z' ./ False ./ 'X' ./ Just 'O' ./ nil + (x & item' @Bool .~ 'Z') `shouldBe` (5 :: Int) ./ 'Z' ./ 'X' ./ Just 'O' ./ nil + (x & item' @Char .~ True) `shouldBe` (5 :: Int) ./ False ./ True ./ Just 'O' ./ nil + (x & item' @(Maybe Char) .~ 'P') `shouldBe` (5 :: Int) ./ False ./ 'X' ./ 'P' ./ nil + it "has getter/setter lens using 'item'" $ do + 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 + + it "has polymorphic getter/setter lens using 'itemL''" $ do + let x = (5 :: Int) ./ Tagged @Foo False ./ Tagged @Bar 'X' ./ nil + (x & itemL' @Foo Proxy .~ "foo") `shouldBe` (5 :: Int) ./ "foo" ./ Tagged @Bar 'X' ./ nil + it "has getter/setter lens for duplicate fields using 'itemN'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + 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' ./ nul + (x & itemN (Proxy @0) .~ 6) `shouldBe` (6 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil x ^. itemN (Proxy @1) `shouldBe` False - (x & itemN (Proxy @1) .~ True) `shouldBe` (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + (x & itemN (Proxy @1) .~ True) `shouldBe` (5 :: Int) ./ True ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil x ^. itemN (Proxy @2) `shouldBe` 'X' - (x & itemN (Proxy @2) .~ 'O') `shouldBe` (5 :: Int) ./ False ./ 'O' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + (x & itemN (Proxy @2) .~ 'O') `shouldBe` (5 :: Int) ./ False ./ 'O' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil x ^. itemN (Proxy @3) `shouldBe` Just 'O' - (x & itemN (Proxy @3) .~ Just 'P') `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ (6 :: Int) ./ Just 'A' ./ nul + (x & itemN (Proxy @3) .~ Just 'P') `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'P' ./ (6 :: Int) ./ Just 'A' ./ nil x ^. itemN (Proxy @4) `shouldBe` 6 - (x & itemN (Proxy @4) .~ 7) `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (7 :: Int) ./ Just 'A' ./ nul + (x & itemN (Proxy @4) .~ 7) `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (7 :: Int) ./ Just 'A' ./ nil x ^. itemN (Proxy @5) `shouldBe` Just 'A' - (x & itemN (Proxy @5) .~ Just 'B') `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'B' ./ nul + (x & itemN (Proxy @5) .~ Just 'B') `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'B' ./ nil it "has polymorphic getter/setter lens for duplicate fields using 'itemN''" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - (x & itemN' (Proxy @0) .~ "Foo") `shouldBe` "Foo" ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - (x & itemN' (Proxy @1) .~ "Foo") `shouldBe` (5 :: Int) ./ "Foo" ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - (x & itemN' (Proxy @2) .~ "Foo") `shouldBe` (5 :: Int) ./ False ./ "Foo" ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - (x & itemN' (Proxy @3) .~ "Foo") `shouldBe` (5 :: Int) ./ False ./ 'X' ./ "Foo" ./ (6 :: Int) ./ Just 'A' ./ nul - (x & itemN' (Proxy @4) .~ "Foo") `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ "Foo" ./ Just 'A' ./ nul - (x & itemN' (Proxy @5) .~ "Foo") `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ "Foo" ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + (x & itemN' (Proxy @0) .~ "Foo") `shouldBe` "Foo" ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + (x & itemN' (Proxy @1) .~ "Foo") `shouldBe` (5 :: Int) ./ "Foo" ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + (x & itemN' (Proxy @2) .~ "Foo") `shouldBe` (5 :: Int) ./ False ./ "Foo" ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + (x & itemN' (Proxy @3) .~ "Foo") `shouldBe` (5 :: Int) ./ False ./ 'X' ./ "Foo" ./ (6 :: Int) ./ Just 'A' ./ nil + (x & itemN' (Proxy @4) .~ "Foo") `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ "Foo" ./ Just 'A' ./ nil + (x & itemN' (Proxy @5) .~ "Foo") `shouldBe` (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ "Foo" ./ nil it "has getter for multiple fields using 'select'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - select @'[Int, Maybe Char] x `shouldBe` (5 :: Int) ./ Just 'O' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + select @'[Int, Maybe Char] x `shouldBe` (5 :: Int) ./ Just 'O' ./ nil + it "has getter for multiple labelled fields using 'selectL'" $ do + let x = False ./ Tagged @"Hi" (5 :: Int) ./ Tagged @Foo False ./ Tagged @Bar 'X' ./ Tagged @"Bye" 'O' ./ nil + selectL @'[Foo, Bar] Proxy x `shouldBe` Tagged @Foo False ./ Tagged @Bar 'X' ./ nil + selectL @'["Hi", "Bye"] Proxy x `shouldBe` Tagged @"Hi" (5 :: Int) ./ Tagged @"Bye" 'O' ./ nil + -- below won't compile because the type of labels must match + -- selectL @'["Hi", 'Foo, "Bye"] Proxy x `shouldBe` Tagged @"Hi" (5 :: Int) ./ Tagged @Foo False ./ Tagged @"Bye" 'O' ./ nil + it "can reorder fields using 'select' or 'selectN'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - select @'[Bool, Int, Maybe Char] x `shouldBe` False ./ (5 :: Int) ./ Just 'O' ./ nul - let y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + select @'[Bool, Int, Maybe Char] x `shouldBe` False ./ (5 :: Int) ./ Just 'O' ./ nil + let y = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil selectN (Proxy @'[5, 4, 0, 1, 3, 2]) y `shouldBe` - Just 'A' ./ (6 :: Int) ./ (5 ::Int) ./ False ./ Just 'O' ./ 'X' ./ nul + Just 'A' ./ (6 :: Int) ./ (5 ::Int) ./ False ./ Just 'O' ./ 'X' ./ nil it "has getter for multiple fields with duplicates using 'selectN'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - selectN (Proxy @'[5, 4, 0]) x `shouldBe` Just 'A' ./ (6 :: Int) ./ (5 ::Int) ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + selectN (Proxy @'[5, 4, 0]) x `shouldBe` Just 'A' ./ (6 :: Int) ./ (5 ::Int) ./ nil it "can't select into types from indistinct fields" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil -- Compile error: Int is a duplicate - -- select @[Bool, Char, Int] x `shouldBe` False ./ 'X' ./ (5 :: Int) ./ nul - x `shouldBe` x + -- select @[Bool, Char, Int] x `shouldBe` False ./ 'X' ./ (5 :: Int) ./ nil + x `shouldBe` x it "with duplicate fields has getter for multiple unique fields 'select'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - select @'[Bool, Char] x `shouldBe` False ./ 'X' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + select @'[Bool, Char] x `shouldBe` False ./ 'X' ./ nil it "has setter for multiple fields using 'amend'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - amend @'[Int, Maybe Char] x ((6 :: Int) ./ Just 'P' ./ nul) `shouldBe` (6 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + amend @'[Int, Maybe Char] x ((6 :: Int) ./ Just 'P' ./ nil) `shouldBe` (6 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nil it "has polymorphc setter for multiple fields using 'amend'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - amend' @'[Int, Maybe Char] Proxy x ("Foo" ./ "Bar" ./ nul) `shouldBe` "Foo" ./ False ./ 'X' ./ "Bar" ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + amend' @'[Int, Maybe Char] Proxy x ("Foo" ./ "Bar" ./ nil) `shouldBe` "Foo" ./ False ./ 'X' ./ "Bar" ./ nil + it "has setter for multiple labelled fields using 'amendL'" $ do + let x = False ./ Tagged @"Hi" (5 :: Int) ./ Tagged @Foo False ./ Tagged @Bar 'X' ./ Tagged @"Bye" 'O' ./ nil + amendL @'[Foo, Bar] Proxy x (Tagged @Foo True ./ Tagged @Bar 'Y' ./ nil) `shouldBe` + False ./ Tagged @"Hi" (5 :: Int) ./ Tagged @Foo True ./ Tagged @Bar 'Y' ./ Tagged @"Bye" 'O' ./ nil + amendL @'["Hi", "Bye"] Proxy x (Tagged @"Hi" (6 :: Int) ./ Tagged @"Bye" 'P' ./ nil) `shouldBe` + False ./ Tagged @"Hi" (6 :: Int) ./ Tagged @Foo False ./ Tagged @Bar 'X' ./ Tagged @"Bye" 'P' ./ nil + + it "has polymorphic setter for multiple labelled fields using 'amendL'" $ do + let x = False ./ Tagged @"Hi" (5 :: Int) ./ Tagged @Foo False ./ Tagged @Bar 'X' ./ Tagged @"Bye" 'O' ./ nil + amendL' @'[Foo, Bar] Proxy x ('Y' ./ True ./ nil) `shouldBe` + False ./ Tagged @"Hi" (5 :: Int) ./ 'Y' ./ True ./ Tagged @"Bye" 'O' ./ nil + amendL' @'["Hi", "Bye"] Proxy x (True ./ Tagged @"Changed" True ./ nil) `shouldBe` + False ./ True ./ Tagged @Foo False ./ Tagged @Bar 'X' ./ Tagged @"Changed" True ./ nil + it "has setter for multiple fields with duplicates using 'amendN'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - amendN (Proxy @'[5, 4, 0]) x (Just 'B' ./ (8 :: Int) ./ (4 ::Int) ./ nul) `shouldBe` - (4 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (8 :: Int) ./ Just 'B' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + amendN (Proxy @'[5, 4, 0]) x (Just 'B' ./ (8 :: Int) ./ (4 ::Int) ./ nil) `shouldBe` + (4 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (8 :: Int) ./ Just 'B' ./ nil it "has polymorphic setter for multiple fields with duplicates using 'amendN''" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - amendN' @'[5, 4, 0] Proxy x ("Foo" ./ Just 'B' ./ 'Z' ./ nul) `shouldBe` - 'Z' ./ False ./ 'X' ./ Just 'O' ./ Just 'B' ./ "Foo" ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + amendN' @'[5, 4, 0] Proxy x ("Foo" ./ Just 'B' ./ 'Z' ./ nil) `shouldBe` + 'Z' ./ False ./ 'X' ./ Just 'O' ./ Just 'B' ./ "Foo" ./ nil it "can't amend into types from indistinct fields" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil -- Compile error: Int is a duplicate - -- amend @ '[Bool, Char, Int] x (True ./ 'B' ./ (8 :: Int) ./ nul) `shouldBe` - -- (5 :: Int) ./ True ./ 'B' ./ Just 'O' ./ (8 :: Int) ./ Just 'A' ./ nul + -- amend @ '[Bool, Char, Int] x (True ./ 'B' ./ (8 :: Int) ./ nil) `shouldBe` + -- (5 :: Int) ./ True ./ 'B' ./ Just 'O' ./ (8 :: Int) ./ Just 'A' ./ nil x `shouldBe` x it "with duplicate fields has setter for unique fields 'amend'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - amend @ '[Bool, Char] x (True ./ 'B' ./ nul) `shouldBe` - (5 :: Int) ./ True ./ 'B' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + amend @ '[Bool, Char] x (True ./ 'B' ./ nil) `shouldBe` + (5 :: Int) ./ True ./ 'B' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil it "has getter/setter lens for multiple fields using 'project'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - x ^. (project @'[Int, Maybe Char]) `shouldBe` (5 :: Int) ./ Just 'O' ./ nul - (x & (project @'[Int, Maybe Char]) .~ ((6 :: Int) ./ Just 'P' ./ nul)) `shouldBe` - (6 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nul + 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` + (6 :: Int) ./ False ./ 'X' ./ Just 'P' ./ nil it "has polymorphic getter/setter lens for multiple fields using 'project'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nul - (x & (project' @'[Int, Maybe Char]) .~ ("Foo" ./ Just "Bar" ./ nul)) `shouldBe` - "Foo" ./ False ./ 'X' ./ Just "Bar" ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ nil + (x & (project' @'[Int, Maybe Char]) .~ ("Foo" ./ Just "Bar" ./ nil)) `shouldBe` + "Foo" ./ False ./ 'X' ./ Just "Bar" ./ nil + it "has getter/setter lens for multiple labelled fields using 'projectL'" $ do + 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` + False ./ Tagged @"Hi" (6 :: Int) ./ Tagged @Foo False ./ Tagged @Bar 'X' ./ Tagged @"Bye" 'P' ./ nil + + it "has polymorphic getter/setter lens for multiple labelled fields using 'projectL''" $ do + 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` + False ./ True ./ Tagged @Foo False ./ Tagged @Bar 'X' ./ Tagged @"Changed" False ./ nil + it "has getter/setter lens for multiple fields with duplicates using 'projectN'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - x ^. (projectN @'[5, 4, 0] Proxy) `shouldBe` Just 'A' ./ (6 :: Int) ./ (5 ::Int) ./ nul - (x & (projectN @'[5, 4, 0] Proxy) .~ (Just 'B' ./ (8 :: Int) ./ (4 ::Int) ./ nul)) `shouldBe` - (4 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (8 :: Int) ./ Just 'B' ./ nul + 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` + (4 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (8 :: Int) ./ Just 'B' ./ nil it "has polymorphic getter/setter lens for multiple fields with duplicates using 'projectN'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - (x & (projectN' @'[5, 4, 0] Proxy) .~ (Just "Foo" ./ (8 :: Int) ./ "Bar" ./ nul)) `shouldBe` - "Bar" ./ False ./ 'X' ./ Just 'O' ./ (8 :: Int) ./ Just "Foo" ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + (x & (projectN' @'[5, 4, 0] Proxy) .~ (Just "Foo" ./ (8 :: Int) ./ "Bar" ./ nil)) `shouldBe` + "Bar" ./ False ./ 'X' ./ Just 'O' ./ (8 :: Int) ./ Just "Foo" ./ nil it "can be folded with 'Many' handlers using 'forMany' or 'collect'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - y = show @Int ./ show @Char ./ show @(Maybe Char) ./ show @Bool ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + y = show @Int ./ show @Char ./ show @(Maybe Char) ./ show @Bool ./ nil ret = ["5", "False", "'X'", "Just 'O'", "6", "Just 'A'"] afoldr (:) [] (collect x (cases y)) `shouldBe` ret afoldr (:) [] (forMany (cases y) x) `shouldBe` ret afoldr (:) [] (forMany (cases y) x) `shouldBe` ret it "can be folded with single 'CaseTypeable' handlers using 'forMany' or 'collect'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil afoldr (:) [] (forMany (CaseTypeable (show . typeRep . (pure @Proxy))) x) `shouldBe` ["Int", "Bool", "Char", "Maybe Char", "Int", "Maybe Char"] it "can be folded with 'Many' handlers in index order using 'forManyN' or 'collectN'" $ do - let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nul - y = show @Int ./ show @Bool ./ show @Char ./ show @(Maybe Char) ./ show @Int ./ show @(Maybe Char) ./ nul + let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil + y = show @Int ./ show @Bool ./ show @Char ./ show @(Maybe Char) ./ show @Int ./ show @(Maybe Char) ./ nil ret = ["5", "False", "'X'", "Just 'O'", "6", "Just 'A'"] afoldr (:) [] (collectN x (casesN y)) `shouldBe` ret afoldr (:) [] (forManyN (casesN y) x) `shouldBe` ret diff --git a/test/Data/Diverse/WhichSpec.hs b/test/Data/Diverse/WhichSpec.hs --- a/test/Data/Diverse/WhichSpec.hs +++ b/test/Data/Diverse/WhichSpec.hs @@ -10,9 +10,15 @@ import Control.Lens import Data.Diverse +import Data.Tagged import Data.Typeable import Test.Hspec +data Foo +data Bar +data Hi +data Bye + -- `main` is here so that this module can be run from GHCi on its own. It is -- not needed for automatic spec discovery. main :: IO () @@ -26,10 +32,14 @@ spec = do describe "Which" $ do + it "is a Show" $ do + let x = pickN @0 Proxy 5 :: Which '[Int, Bool] + show x `shouldBe` "pickN @0 Proxy 5" + it "is a Read and Show" $ do - let s = "pick 5" + let s = "pickN @0 Proxy 5" x = read s :: Which '[Int, Bool] - show x `shouldBe` "pick 5" + show x `shouldBe` s "impossible" `shouldBe` show impossible "impossible" `shouldBe` show (read "impossible" :: Which '[]) @@ -52,6 +62,11 @@ x = hush $ trial @Int y x `shouldBe` (Just 5) + it "can be constructed by label with 'pickL' and destructed with 'trialL'" $ do + let y = pickL @Foo Proxy (Tagged (5 :: Int)) :: Which '[Bool, Tagged Foo Int, Tagged Bar Char] + x = hush $ trialL @Foo Proxy y + x `shouldBe` (Just (Tagged 5)) + it "may contain possiblities of duplicate types" $ do let y = pick (5 :: Int) :: Which '[Bool, Int, Char, Bool, Char] x = hush $ trial @Int y @@ -121,6 +136,11 @@ 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 Proxy) (Tagged (5 :: Int)) :: Which '[Tagged Foo Bool, Tagged Bar Int, Char, Bool, Char] + x = preview (facetL @Bar Proxy) y + x `shouldBe` (Just (Tagged 5)) + it "can be constructed and destructed by index with 'facetN'" $ do let y = review (facetN (Proxy @4)) (5 :: Int) :: Which '[Bool, Int, Char, Bool, Int, Char] x = preview (facetN (Proxy @4)) y @@ -132,6 +152,12 @@ y'' = diversify @[Bool, Int] y' switch y'' (CaseTypeable (show . typeRep . (pure @Proxy))) `shouldBe` "Int" + it "can be extended and rearranged by type with 'diversify'" $ do + let y = pickOnly (5 :: Tagged Bar Int) + y' = diversifyL @'[Bar] Proxy y :: Which '[Tagged Bar Int, Tagged Foo Bool] + y'' = diversifyL @'[Bar, Foo] Proxy y' :: Which '[Tagged Foo Bool, Tagged Bar Int] + switch y'' (CaseTypeable (show . typeRep . (pure @Proxy))) `shouldBe` "Tagged * Bar Int" + it "can be extended and rearranged by index with 'diversifyN'" $ do let y = pickOnly (5 :: Int) y' = diversifyN @'[0] @[Int, Bool] Proxy y @@ -160,6 +186,12 @@ let c = reinterpret @[String, Int] y c `shouldBe` Right (pick (5 :: Int)) + it "can be 'reinterpretL'ed by label into a totally different Which" $ do + let y = pick @[Tagged Bar Int, Tagged Foo Bool, Tagged Hi Char, Tagged Bye Bool] (5 :: Tagged Bar Int) + y' = reinterpretL @[Foo, Bar] Proxy y + x = pick @[Tagged Foo Bool, Tagged Bar Int] (5 :: Tagged Bar Int) + y' `shouldBe` Right x + it "the 'reinterpret' type can contain indistinct fields if they aren't in the original 'Many'" $ do let y = pick @[Int, Char] (5 :: Int) x = reinterpret @[String, String, Char, Bool] y @@ -193,6 +225,14 @@ let y' = preview (inject @[String, Int]) y y' `shouldBe` Just (pick (5 :: Int)) + 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) + 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 `shouldBe` t' + b' `shouldBe` Just b + it "can be 'diversifyN'ed and 'reinterpretedN' by index with 'injectN'" $ do let x = pick (5 :: Int) :: Which '[String, Int] y = review (injectN @[3, 1] @_ @[Bool, Int, Char, String] Proxy) x @@ -205,7 +245,7 @@ switch y ( cases (show @Bool ./ show @Int - ./ nul)) `shouldBe` "5" + ./ nil)) `shouldBe` "5" it "can be 'switch'ed with 'Many' handlers with extraneous content" $ do let y = pick (5 :: Int) :: Which '[Int, Bool] @@ -216,7 +256,7 @@ ./ show @Char ./ 'X' ./ False - ./ nul + ./ nil )) `shouldBe` "5" it "can be 'switchN'ed with 'Many' handlers in index order" $ do @@ -226,7 +266,7 @@ ./ show @Bool ./ show @Bool ./ show @Int - ./ nul)) `shouldBe` "5" + ./ nil)) `shouldBe` "5" it "can be switched with a single 'CaseTypeable' handler" $ do let y = pick (5 :: Int) :: Which '[Int, Bool]