module Data.Diverse.Many.Internal (
Many(..)
, IsMany(..)
, fromMany'
, toMany'
, _Many
, _Many'
, nul
, single
, prefix
, (./)
, postfix
, (\.)
, append
, (/./)
, front
, back
, aft
, fore
, fetch
, fetchN
, replace
, replace'
, replaceN
, replaceN'
, item
, item'
, itemN
, itemN'
, Select
, select
, SelectN
, selectN
, Amend
, amend
, Amend'
, amend'
, AmendN
, amendN
, AmendN'
, amendN'
, project
, project'
, projectN
, projectN'
, Via
, via
, forMany
, collect
, ViaN
, viaN
, forManyN
, collectN
) where
import Control.Applicative
import Control.Lens
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
import qualified Data.Map.Strict as M
import Data.Proxy
import Data.Tagged
import qualified GHC.Generics as G
import GHC.Prim (Any, coerce)
import GHC.TypeLits
import Text.ParserCombinators.ReadPrec
import Text.Read
import qualified Text.Read.Lex as L
import Unsafe.Coerce
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 }
data Many (xs :: [Type]) = Many !Int (M.Map Key Any)
type role Many representational
instance G.Generic (Many '[]) where
type Rep (Many '[]) = G.U1
from _ = G.U1
to G.U1 = nul
instance G.Generic (Many (x ': xs)) where
type Rep (Many (x ': xs)) = (G.Rec0 x) G.:*: (G.Rec0 (Many xs))
from r = ( G.K1 (front r)) G.:*: ( G.K1 (aft r))
to (( G.K1 a) G.:*: ( G.K1 b)) = a ./ b
class IsMany t xs a where
toMany :: t xs a -> Many xs
fromMany :: Many xs -> t xs a
toMany' :: IsMany Tagged xs a => a -> Many xs
toMany' a = toMany (Tagged a)
fromMany' :: IsMany Tagged xs a => Many xs -> a
fromMany' = unTagged . fromMany
_Many :: IsMany t xs a => Iso' (Many xs) (t xs a)
_Many = iso fromMany toMany
_Many' :: IsMany Tagged xs a => Iso' (Many xs) a
_Many' = iso fromMany' toMany'
instance IsMany Tagged '[] () where
toMany _ = nul
fromMany _ = Tagged ()
instance IsMany Tagged '[a] a where
toMany (Tagged a) = single a
fromMany r = Tagged (fetch @a r)
instance IsMany Tagged '[a,b] (a,b) where
toMany (Tagged (a,b)) = a./b./nul
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
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
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
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
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
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
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
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
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
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
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
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
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
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)
rightKeyForSnoc :: LeftOffset -> LeftSize -> RightOffset -> Key -> Key
rightKeyForSnoc (LeftOffset lo) (LeftSize ld) (RightOffset ro) (Key rk) =
Key (rk ro + lo + ld)
rightOffsetForCons :: LeftSize -> RightOffset -> NewRightOffset
rightOffsetForCons (LeftSize ld) (RightOffset ro) = NewRightOffset (ro ld)
leftKeyForCons :: LeftOffset -> NewRightOffset -> Key -> Key
leftKeyForCons (LeftOffset lo) (NewRightOffset ro) (Key lk) = Key (lk lo + ro)
nul :: Many '[]
nul = Many 0 M.empty
infixr 5 `nul`
single :: x -> Many '[x]
single v = Many 0 (M.singleton (Key 0) (unsafeCoerce v))
prefix :: x -> Many xs -> Many (x ': xs)
prefix x (Many ro rm) = Many (unNewRightOffset nro)
(M.insert
(leftKeyForCons (LeftOffset 0) nro (Key 0))
(unsafeCoerce x)
rm)
where
nro = rightOffsetForCons (LeftSize 1) (RightOffset ro)
infixr 5 `prefix`
(./) :: x -> Many xs -> Many (x ': xs)
(./) = prefix
infixr 5 ./
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))
(unsafeCoerce y)
lm)
infixl 5 `postfix`
(\.) :: Many xs -> y -> Many (Append xs '[y])
(\.) = postfix
infixl 5 \.
(/./) :: Many xs -> Many ys -> Many (Append xs ys)
(/./) = append
infixr 5 /./
append :: Many xs -> Many ys -> Many (Append xs ys)
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))
else Many
(unNewRightOffset nro)
((M.mapKeys (leftKeyForCons (LeftOffset lo) nro) lm) `M.union` rm)
where
ld = M.size lm
rd = M.size rm
nro = rightOffsetForCons (LeftSize ld) (RightOffset ro)
infixr 5 `append`
front :: Many (x ': xs) -> x
front (Many _ m) = unsafeCoerce (snd . Partial.head $ M.toAscList m)
back :: Many (x ': xs) -> Last (x ': xs)
back (Many _ m) = unsafeCoerce (snd . Partial.head $ M.toDescList m)
aft :: Many (x ': xs) -> Many xs
aft (Many o m) = Many (o + 1) (M.delete (Key o) m)
fore :: Many (x ': xs) -> Many (Init (x ': xs))
fore (Many o m) = Many o (M.delete (Key (o + M.size m 1)) m)
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)
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)))
where i = fromInteger (natVal p)
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' :: 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)
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)
where i = fromInteger (natVal p)
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)
where i = fromInteger (natVal p)
item :: forall x xs. UniqueMember x xs => Lens' (Many xs) x
item = lens fetch replace
item' :: forall x y xs. UniqueMember x xs => Lens (Many xs) (Many (Replace x y xs)) x y
item' = lens fetch (replace' @x @y Proxy)
itemN :: forall n x xs proxy. MemberAt n x xs => proxy n -> Lens' (Many xs) x
itemN p = lens (fetchN p) (replaceN p)
itemN' :: forall n x y xs proxy. MemberAt n x xs => proxy n -> Lens (Many xs) (Many (ReplaceIndex n y xs)) x y
itemN' p = lens (fetchN p) (replaceN' @n @x @y p)
fromList' :: Ord k => [(k, WrappedAny)] -> M.Map k Any
fromList' xs = M.fromList (coerce xs)
newtype Via c (xs :: [Type]) r = Via (c xs r, [Any])
via :: c xs r -> Many xs -> Via c xs r
via c (Many _ m) = Via (c, snd <$> M.toAscList m)
instance Reiterate c (x ': xs) => Reiterate (Via c) (x ': xs) where
reiterate (Via (c, xxs)) = Via (reiterate c, Partial.tail xxs)
instance (Case c (x ': xs) r) => Emit (Via c) (x ': xs) r where
emit (Via (c, xxs)) = caseAny c v
where
v = Partial.head xxs
forMany :: c xs r -> Many xs -> Collector (Via c) xs r
forMany c x = Collector (via c x)
collect :: Many xs -> c xs r -> Collector (Via c) xs r
collect = flip forMany
newtype ViaN c (n :: Nat) (xs :: [Type]) r = ViaN (c n xs r, [Any])
viaN :: c n xs r -> Many xs -> ViaN c n xs r
viaN c (Many _ m) = ViaN (c, snd <$> M.toAscList m)
instance ReiterateN c n (x ': xs) => ReiterateN (ViaN c) n (x ': xs) where
reiterateN (ViaN (c, xxs)) = ViaN (reiterateN c, Partial.tail xxs)
instance (Case (c n) (x ': xs) r) => Emit (ViaN c n) (x ': xs) r where
emit (ViaN (c, xxs)) = caseAny c v
where
v = Partial.head xxs
forManyN :: c n xs r -> Many xs -> CollectorN (ViaN c) n xs r
forManyN c x = CollectorN (viaN c x)
collectN :: Many xs -> c n xs r -> CollectorN (ViaN c) n xs r
collectN = flip forManyN
type Select (smaller :: [Type]) (larger :: [Type]) =
(AFoldable
( Collector (Via (CaseSelect smaller larger)) larger) [(Key, WrappedAny)])
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))
data CaseSelect (smaller :: [Type]) (larger :: [Type]) (xs :: [Type]) r = CaseSelect
instance Reiterate (CaseSelect smaller larger) (x ': xs) where
reiterate CaseSelect = CaseSelect
instance forall smaller larger x xs. (UniqueIfExists smaller x larger, MaybeUniqueMember x smaller) =>
Case (CaseSelect smaller larger) (x ': xs) [(Key, WrappedAny)] where
caseAny _ v =
case i of
0 -> []
i' -> [(Key (i' 1), WrappedAny v)]
where
i = fromInteger (natVal @(PositionOf x smaller) Proxy)
type SelectN (ns :: [Nat]) (smaller ::[Type]) (larger :: [Type]) =
( AFoldable (CollectorN (ViaN (CaseSelectN ns smaller)) 0 larger) [(Key, WrappedAny)]
, smaller ~ KindsAtIndices ns larger
, IsDistinct ns)
selectN
:: forall ns smaller larger proxy.
SelectN ns smaller larger
=> proxy ns -> Many larger -> Many smaller
selectN _ xs = Many 0 (fromList' xs')
where
xs' = afoldr (++) [] (forManyN (CaseSelectN @ns @smaller @0 @larger) xs)
data CaseSelectN (indices :: [Nat]) (smaller :: [Type]) (n :: Nat) (xs :: [Type]) r = CaseSelectN
instance ReiterateN (CaseSelectN indices smaller) n (x ': xs) where
reiterateN CaseSelectN = CaseSelectN
instance forall indices smaller n x xs. MaybeMemberAt (PositionOf n indices) x smaller =>
Case (CaseSelectN indices smaller n) (x ': xs) [(Key, WrappedAny)] where
caseAny _ v =
case i of
0 -> []
i' -> [(Key (i' 1), WrappedAny v)]
where
i = fromInteger (natVal @(PositionOf n indices) Proxy)
type Amend smaller larger = (AFoldable (Collector (Via (CaseAmend larger)) smaller) (Key, WrappedAny)
, IsDistinct smaller)
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)
newtype CaseAmend (larger :: [Type]) (xs :: [Type]) r = CaseAmend Int
instance Reiterate (CaseAmend larger) (x ': xs) where
reiterate (CaseAmend lo) = CaseAmend lo
instance UniqueMember x larger => Case (CaseAmend larger) (x ': xs) (Key, WrappedAny) where
caseAny (CaseAmend lo) v = (Key (lo + i), WrappedAny v)
where
i = fromInteger (natVal @(IndexOf x larger) Proxy)
type Amend' smaller smaller' larger = (AFoldable (Collector (Via (CaseAmend' larger)) (Zip smaller smaller')) (Key, WrappedAny), IsDistinct smaller)
amend' :: forall smaller smaller' larger. Amend' smaller smaller' larger
=> 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))
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)
newtype CaseAmend' (larger :: [Type]) (zs :: [Type]) r = CaseAmend' Int
instance Reiterate (CaseAmend' larger) (z ': zs) where
reiterate (CaseAmend' lo) = CaseAmend' lo
instance UniqueMember x larger => Case (CaseAmend' larger) ((x, y) ': zs) (Key, WrappedAny) where
caseAny (CaseAmend' lo) v = (Key (lo + i), WrappedAny v)
where
i = fromInteger (natVal @(IndexOf x larger) Proxy)
type AmendN ns smaller larger =
( AFoldable (CollectorN (ViaN (CaseAmendN ns larger)) 0 smaller) (Key, WrappedAny)
, smaller ~ KindsAtIndices ns larger
, IsDistinct ns)
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)
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
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)
where
i = fromInteger (natVal @(KindAtIndex n indices) Proxy)
type AmendN' ns smaller smaller' larger =
( AFoldable (CollectorN (ViaN (CaseAmendN' ns larger)) 0 (Zip smaller smaller')) (Key, WrappedAny)
, smaller ~ KindsAtIndices ns larger
, IsDistinct ns)
amendN' :: forall ns smaller smaller' larger proxy.
(AmendN' ns smaller smaller' larger)
=> 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))
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)
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
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)
where
i = fromInteger (natVal @(KindAtIndex n indices) Proxy)
project
:: forall smaller larger.
(Select smaller larger, Amend smaller larger)
=> Lens' (Many larger) (Many smaller)
project = lens select amend
project'
:: forall smaller smaller' larger.
(Select smaller larger, Amend' smaller smaller' larger)
=> Lens (Many larger) (Many (Replaces smaller smaller' larger)) (Many smaller) (Many smaller')
project' = lens select (amend' @smaller @smaller' Proxy)
projectN
:: forall ns smaller larger proxy.
(SelectN ns smaller larger, AmendN ns smaller larger)
=> proxy ns -> Lens' (Many larger) (Many smaller)
projectN p = lens (selectN p) (amendN p)
projectN'
:: forall ns smaller smaller' larger proxy.
(SelectN ns smaller larger, AmendN' ns smaller smaller' larger)
=> proxy ns -> Lens (Many larger) (Many (ReplacesIndex ns smaller' larger)) (Many smaller) (Many smaller')
projectN' p = lens (selectN p) (amendN' p)
newtype EmitEqMany (xs :: [Type]) r = EmitEqMany ([Any], [Any])
instance Reiterate EmitEqMany (x ': xs) where
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
l = unsafeCoerce (Partial.head ls) :: x
r = unsafeCoerce (Partial.head rs) :: x
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 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
newtype EmitOrdMany (xs :: [Type]) r = EmitOrdMany ([Any], [Any])
instance Reiterate EmitOrdMany (x ': xs) where
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
l = unsafeCoerce (Partial.head ls) :: x
r = unsafeCoerce (Partial.head rs) :: x
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 (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
newtype EmitShowMany (xs :: [Type]) r = EmitShowMany [Any]
instance Reiterate EmitShowMany (x ': xs) where
reiterate (EmitShowMany xxs) = EmitShowMany (Partial.tail xxs)
instance Emit EmitShowMany '[] ShowS where
emit _ = showString "nul"
instance Show x => Emit EmitShowMany (x ': xs) ShowS where
emit (EmitShowMany xxs) = showsPrec (cons_prec + 1) v . showString " ./ "
where
v = unsafeCoerce (Partial.head xxs) :: x
cons_prec = 5
showMany
:: forall xs.
AFoldable (Collector0 EmitShowMany xs) ShowS
=> Many xs -> ShowS
showMany (Many _ m) = afoldr (.) id (Collector0 (EmitShowMany @xs (snd <$> M.toAscList m)))
instance AFoldable (Collector0 EmitShowMany xs) ShowS => Show (Many xs) where
showsPrec d t = showParen (d > cons_prec) $ showMany t
where
cons_prec = 5
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 x => Emit EmitReadMany (x ': xs) (ReadPrec [(Key, WrappedAny)]) where
emit (EmitReadMany i) = do
a <- 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)))
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))
newtype WrappedAny = WrappedAny Any