module Data.Diverse.Many.Internal (
Many(..)
, IsMany(..)
, fromMany'
, toMany'
, nil
, single
, prefix
, (./)
, postfix
, postfix'
, (\.)
, append
, CanAppendUnique(..)
, (/./)
, viewf
, viewb
, front
, back
, aft
, fore
, fetch
, fetchL
, fetchN
, replace
, replace'
, replaceL
, replaceL'
, replaceN
, replaceN'
, Select
, select
, selectL
, SelectN
, selectN
, Amend
, amend
, Amend'
, amend'
, amendL
, amendL'
, AmendN
, amendN
, AmendN'
, amendN'
, Collect
, Collector
, forMany
, collect
, CollectN
, CollectorN
, forManyN
, collectN
, splitBefore
, splitBeforeL
, splitBeforeN
, splitAfter
, splitAfterL
, splitAfterN
, insetBefore
, insetBeforeL
, insetBeforeN
, insetAfter
, insetAfterL
, insetAfterN
, insertBefore
, insertBeforeL
, insertBeforeN
, insertAfter
, insertAfterL
, insertAfterN
, remove
, removeL
, removeN
) where
import Control.Applicative
import Control.DeepSeq
import Data.Bool
import Data.Diverse.AFoldable
import Data.Diverse.AFunctor
import Data.Diverse.Case
import Data.Diverse.Reiterate
import Data.Diverse.TypeLevel
import Data.Foldable
import Data.Kind
import Data.Proxy
import qualified Data.Sequence as S
import Data.Semigroup (Semigroup(..))
import Data.Tagged
import qualified GHC.Generics as G
import GHC.Exts (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 Many (xs :: [Type]) = Many (S.Seq Any)
type role Many representational
newtype Many_ (xs :: [Type]) = Many_ { runMany_ :: [Any] }
type role Many_ representational
toMany_ :: Many xs -> Many_ xs
toMany_ (Many m) = Many_ (toList m)
fromMany_ :: Many_ xs -> Many xs
fromMany_ (Many_ xs) = Many (S.fromList xs)
getMany_ :: Many_ xs -> [Any]
getMany_ (Many_ xs) = xs
instance NFData (Many '[])
instance (NFData x, NFData (Many xs)) => NFData (Many (x ': xs))
instance G.Generic (Many '[]) where
type Rep (Many '[]) = G.U1
from _ = G.U1
to G.U1 = nil
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
instance IsMany Tagged '[] () where
toMany _ = nil
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./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./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./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./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./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./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./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./ 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./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./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./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./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./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./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)
nil :: Many '[]
nil = Many S.empty
single :: x -> Many '[x]
single v = Many (S.singleton (unsafeCoerce v))
prefix :: x -> Many xs -> Many (x ': xs)
prefix x (Many rs) = Many ((unsafeCoerce x) S.<| rs)
infixr 5 `prefix`
prefix_ :: x -> Many_ xs -> Many_ (x ': xs)
prefix_ x (Many_ xs) = Many_ (unsafeCoerce x : xs)
(./) :: x -> Many xs -> Many (x ': xs)
(./) = prefix
infixr 5 ./
postfix :: Many xs -> y -> Many (Append xs '[y])
postfix (Many ls) y = Many (ls S.|> (unsafeCoerce y))
infixl 5 `postfix`
postfix'
:: forall y xs n.
MaybeUniqueMemberAt n y xs
=> Many xs -> y -> Many (SnocUnique xs y)
postfix'(Many ls) y = if i /= 0 then Many ls else Many (ls S.|> unsafeCoerce y)
where
i = fromInteger (natVal @n Proxy) :: Int
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 ls) (Many rs) = Many (ls S.>< rs)
infixr 5 `append`
class CanAppendUnique xs ys where
append' :: Many xs -> Many ys -> Many (AppendUnique xs ys)
instance CanAppendUnique xs '[] where
append' ls _ = ls
instance ( MaybeUniqueMemberAt n y xs
, CanAppendUnique (SnocUnique xs y) ys
, AppendUnique (SnocUnique xs y) ys ~ AppendUnique xs (y : ys)) => CanAppendUnique xs (y ': ys) where
append' ls rs = append' (postfix' ls r) rs'
where (r, rs') = viewf rs
infixr 5 `append'`
viewf :: Many (x ': xs) -> (x, Many xs)
viewf (Many xs) = case S.viewl xs of
S.EmptyL -> error "no front"
(a S.:< ys) -> (unsafeCoerce a, Many ys)
viewb :: Many (x ': xs) -> (Many (Init (x ': xs)), Last (x ': xs))
viewb (Many xs) = case S.viewr xs of
S.EmptyR -> error "no back"
(ys S.:> a) -> (Many ys, unsafeCoerce a)
front :: Many (x ': xs) -> x
front = fst . viewf
front_ :: Many_ (x ': xs) -> x
front_ (Many_ xs) = unsafeCoerce (Partial.head xs)
back :: Many (x ': xs) -> Last (x ': xs)
back = snd . viewb
aft :: Many (x ': xs) -> Many xs
aft = snd . viewf
aft_ :: Many_ (x ': xs) -> Many_ xs
aft_ (Many_ xs) = Many_ (Partial.tail xs)
fore :: Many (x ': xs) -> Many (Init (x ': xs))
fore = fst . viewb
splitAfter_
:: forall x xs n proxy.
(KnownNat n, n ~ IndexOf x xs)
=> proxy x -> Many xs -> (Many (To x xs), Many (After x xs))
splitAfter_ _ (Many xs) = let (as, bs) = S.splitAt (i + 1) xs in (Many as, Many bs)
where
i = fromInteger (natVal @n Proxy) :: Int
splitBefore_
:: forall x xs n proxy.
(KnownNat n, n ~ IndexOf x xs)
=> proxy x -> Many xs -> (Many (Before x xs), Many (From x xs))
splitBefore_ _ (Many xs) = let (as, bs) = S.splitAt i xs in (Many as, Many bs)
where
i = fromInteger (natVal @n Proxy) :: Int
splitAfter
:: forall x xs proxy.
(UniqueMember x xs)
=> proxy x -> Many xs -> (Many (To x xs), Many (After x xs))
splitAfter _ = splitAfter_ (Proxy @x)
splitBefore
:: forall x xs proxy.
(UniqueMember x xs)
=> proxy x -> Many xs -> (Many (Before x xs), Many (From x xs))
splitBefore _ = splitBefore_ (Proxy @x)
splitAfterL
:: forall l xs proxy x.
(UniqueLabelMember l xs, x ~ KindAtLabel l xs)
=> proxy l -> Many xs -> (Many (To x xs), Many (After x xs))
splitAfterL _ = splitAfter_ (Proxy @x)
splitBeforeL
:: forall l xs proxy x.
(UniqueLabelMember l xs, x ~ KindAtLabel l xs)
=> proxy l -> Many xs -> (Many (Before x xs), Many (From x xs))
splitBeforeL _ = splitBefore_ (Proxy @x)
splitAfterN
:: forall n xs proxy.
(KnownNat n, n + 1 <= Length xs)
=> proxy n -> Many xs -> (Many (ToIndex n xs), Many (AfterIndex n xs))
splitAfterN _ (Many xs) = let (as, bs) = S.splitAt (i + 1) xs in (Many as, Many bs)
where
i = fromInteger (natVal @n Proxy) :: Int
splitBeforeN
:: forall n xs proxy.
(KnownNat n, n + 1 <= Length xs)
=> proxy n -> Many xs -> (Many (BeforeIndex n xs), Many (FromIndex n xs))
splitBeforeN _ (Many xs) = let (as, bs) = S.splitAt i xs in (Many as, Many bs)
where
i = fromInteger (natVal @n Proxy) :: Int
insetAfter_
:: forall x ys xs n proxy.
(KnownNat n, n ~ IndexOf x xs)
=> proxy x -> Many ys -> Many xs -> Many (Append (To x xs) (Append ys (After x xs)))
insetAfter_ _ (Many ys) (Many xs) = let (as, bs) = S.splitAt (i + 1) xs in Many (as S.>< ys S.>< bs)
where
i = fromInteger (natVal @n Proxy) :: Int
insetBefore_
:: forall x ys xs n proxy.
(KnownNat n, n ~ IndexOf x xs)
=> proxy x -> Many ys -> Many xs -> Many (Append (Before x xs) (Append ys (From x xs)))
insetBefore_ _ (Many ys) (Many xs) = let (as, bs) = S.splitAt i xs in Many (as S.>< ys S.>< bs)
where
i = fromInteger (natVal @n Proxy) :: Int
insetAfter
:: forall x ys xs proxy.
(UniqueMember x xs)
=> proxy x -> Many ys -> Many xs -> Many (Append (To x xs) (Append ys (After x xs)))
insetAfter _ = insetAfter_ (Proxy @x)
insetBefore
:: forall x ys xs proxy.
(UniqueMember x xs)
=> proxy x -> Many ys -> Many xs -> Many (Append (Before x xs) (Append ys (From x xs)))
insetBefore _ = insetBefore_ (Proxy @x)
insetAfterL
:: forall l ys xs proxy x.
(UniqueLabelMember l xs, x ~ KindAtLabel l xs)
=> proxy l -> Many ys -> Many xs -> Many (Append (To x xs) (Append ys (After x xs)))
insetAfterL _ = insetAfter_ (Proxy @x)
insetBeforeL
:: forall l ys xs proxy x.
(UniqueLabelMember l xs, x ~ KindAtLabel l xs)
=> proxy l -> Many ys -> Many xs -> Many (Append (Before x xs) (Append ys (From x xs)))
insetBeforeL _ = insetBefore_ (Proxy @x)
insetAfterN
:: forall n ys xs proxy.
(KnownNat n, n + 1 <= Length xs)
=> proxy n -> Many ys -> Many xs -> Many (Append (ToIndex n xs) (Append ys (AfterIndex n xs)))
insetAfterN _ (Many ys) (Many xs) = let (as, bs) = S.splitAt (i + 1) xs in Many (as S.>< ys S.>< bs)
where
i = fromInteger (natVal @n Proxy) :: Int
insetBeforeN
:: forall n ys xs proxy.
(KnownNat n, n + 1 <= Length xs)
=> proxy n -> Many ys -> Many xs -> Many (Append (BeforeIndex n xs) (Append ys (FromIndex n xs)))
insetBeforeN _ (Many ys) (Many xs) = let (as, bs) = S.splitAt i xs in Many (as S.>< ys S.>< bs)
where
i = fromInteger (natVal @n Proxy) :: Int
insertAfter_
:: forall x y xs n proxy.
(KnownNat n, n ~ IndexOf x xs)
=> proxy x -> y -> Many xs -> Many (Append (To x xs) (y ': After x xs))
insertAfter_ _ y (Many xs) = Many (S.insertAt (i + 1) (unsafeCoerce y) xs)
where
i = fromInteger (natVal @n Proxy) :: Int
insertBefore_
:: forall x y xs n proxy.
(KnownNat n, n ~ IndexOf x xs)
=> proxy x -> y -> Many xs -> Many (Append (Before x xs) (y ': From x xs))
insertBefore_ _ y (Many xs) = Many (S.insertAt i (unsafeCoerce y) xs)
where
i = fromInteger (natVal @n Proxy) :: Int
insertAfter
:: forall x y xs proxy.
(UniqueMember x xs)
=> proxy x -> y -> Many xs -> Many (Append (To x xs) (y ': After x xs))
insertAfter _ = insertAfter_ (Proxy @x)
insertBefore
:: forall x y xs proxy.
(UniqueMember x xs)
=> proxy x -> y -> Many xs -> Many (Append (Before x xs) (y ': From x xs))
insertBefore _ = insertBefore_ (Proxy @x)
insertAfterL
:: forall l y xs proxy x.
(UniqueLabelMember l xs, x ~ KindAtLabel l xs)
=> proxy l -> y -> Many xs -> Many (Append (To x xs) (y ': After x xs))
insertAfterL _ = insertAfter_ (Proxy @x)
insertBeforeL
:: forall l y xs proxy x.
(UniqueLabelMember l xs, x ~ KindAtLabel l xs)
=> proxy l -> y -> Many xs -> Many (Append (Before x xs) (y ': From x xs))
insertBeforeL _ = insertBefore_ (Proxy @x)
insertAfterN
:: forall n y xs proxy.
(KnownNat n, n + 1 <= Length xs)
=> proxy n -> y -> Many xs -> Many (Append (ToIndex n xs) (y ': AfterIndex n xs))
insertAfterN _ y (Many xs) = Many (S.insertAt (i + 1) (unsafeCoerce y) xs)
where
i = fromInteger (natVal @n Proxy) :: Int
insertBeforeN
:: forall n y xs proxy.
(KnownNat n, n + 1 <= Length xs)
=> proxy n -> y -> Many xs -> Many (Append (BeforeIndex n xs) (y ': FromIndex n xs))
insertBeforeN _ y (Many xs) = Many (S.insertAt i (unsafeCoerce y) xs)
where
i = fromInteger (natVal @n Proxy) :: Int
remove_
:: forall x xs n proxy.
(KnownNat n, n ~ IndexOf x xs)
=> proxy x -> Many xs -> Many (Remove x xs)
remove_ _ (Many xs) = Many (S.deleteAt i xs)
where
i = fromInteger (natVal @n Proxy) :: Int
remove
:: forall x xs proxy.
(UniqueMember x xs)
=> proxy x -> Many xs -> Many (Remove x xs)
remove _ = remove_ (Proxy @x)
removeL
:: forall l xs proxy x.
(UniqueLabelMember l xs, x ~ KindAtLabel l xs)
=> proxy l -> Many xs -> Many (Remove x xs)
removeL _ = remove_ (Proxy @x)
removeN
:: forall n xs proxy.
(KnownNat n, n + 1 <= Length xs)
=> proxy n -> Many xs -> Many (RemoveIndex n xs)
removeN _ (Many xs) = Many (S.deleteAt i xs)
where
i = fromInteger (natVal @n Proxy) :: Int
fetch :: forall x xs. UniqueMember x xs => Many xs -> x
fetch = fetch_
fetch_ :: forall x xs n. (KnownNat n, n ~ IndexOf x xs) => Many xs -> x
fetch_ (Many xs) = let !x = S.index xs i in (unsafeCoerce x)
where i = fromInteger (natVal @n Proxy)
fetchL :: forall l xs proxy x. (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => proxy l -> Many xs -> x
fetchL _ = fetch_ @x
fetchN :: forall n xs proxy x. MemberAt n x xs => proxy n -> Many xs -> x
fetchN p (Many xs) = let !x = S.index xs i in (unsafeCoerce x)
where i = fromInteger (natVal p)
replace :: forall x xs. UniqueMember x xs => Many xs -> x -> Many xs
replace = replace_
replace_ :: forall x xs n. (KnownNat n, n ~ IndexOf x xs) => Many xs -> x -> Many xs
replace_ (Many xs) v = Many (S.update i (unsafeCoerce v) xs)
where i = fromInteger (natVal @n 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 proxy n. (KnownNat n, n ~ IndexOf x xs) => proxy x -> Many xs -> y -> Many (Replace x y xs)
replace'_ _ (Many xs) v = Many (S.update i (unsafeCoerce v) xs)
where i = fromInteger (natVal @n Proxy)
replaceL :: forall l xs proxy x. (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => proxy l -> Many xs -> x -> Many xs
replaceL _ = replace_ @x
replaceL' :: forall l y xs proxy x. (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => proxy l -> Many xs -> y -> Many (Replace x y xs)
replaceL' _ = replace'_ @x Proxy
replaceN :: forall n xs proxy x. MemberAt n x xs => proxy n -> Many xs -> x -> Many xs
replaceN p (Many xs) v = Many (S.update i (unsafeCoerce v) xs)
where i = fromInteger (natVal p)
replaceN' :: forall n y xs proxy x. MemberAt n x xs => proxy n -> Many xs -> y -> Many (ReplaceIndex n y xs)
replaceN' p (Many xs) v = Many (S.update i (unsafeCoerce v) xs)
where i = fromInteger (natVal p)
fromList' :: [(Int, WrappedAny)] -> S.Seq Any
fromList' = fmap (\(_, a) -> coerce a) . S.unstableSortBy (\(i, _) (j, _) -> compare i j) . S.fromList
class CaseAny c (xs :: [Type]) where
caseAny :: c xs -> Any -> CaseResult c Any
data CollectorAny c (xs :: [Type]) r = CollectorAny (c r xs) [Any]
instance AFoldable (CollectorAny c '[]) r where
afoldr _ z _ = z
instance ( CaseAny (c r) (x ': xs)
, Reiterate (c r) (x ': xs)
, AFoldable (CollectorAny c xs) r
, r ~ CaseResult (c r) Any
) =>
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
x = Partial.head xs
xs' = Partial.tail xs
forMany' :: c r xs -> Many xs -> CollectorAny c xs r
forMany' c (Many xs) = CollectorAny c (toList xs)
data CollectorAnyN c n (xs :: [Type]) r = CollectorAnyN (c r n xs) [Any]
instance AFoldable (CollectorAnyN c n '[]) r where
afoldr _ z _ = z
instance ( CaseAny (c r n) (x ': xs)
, ReiterateN (c r) n (x ': xs)
, AFoldable (CollectorAnyN c (n + 1) xs) r
, r ~ CaseResult (c r n) Any
) =>
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
x = Partial.head xs
xs' = Partial.tail xs
forManyN' :: c r n xs -> Many xs -> CollectorAnyN c n xs r
forManyN' c (Many xs) = CollectorAnyN c (toList xs)
data Collector c (xs :: [Type]) r = Collector (c r xs) [Any]
instance AFoldable (Collector c '[]) r where
afoldr _ z _ = z
instance ( Case (c r) (x ': xs)
, Reiterate (c r) (x ': xs)
, AFoldable (Collector c xs) r
, r ~ CaseResult (c r) x
) =>
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
v = unsafeCoerce $ Partial.head xs
xs' = Partial.tail xs
instance AFunctor Many_ c '[] where
afmap _ = id
instance ( Reiterate c (a ': as)
, AFunctor Many_ c as
, Case c (a ': as)
) =>
AFunctor Many_ c (a ': as) where
afmap c (Many_ as) =
Many_ $
unsafeCoerce (case' c a) :
runMany_
(afmap
(reiterate c)
(Many_ as' :: Many_ as))
where
a = unsafeCoerce (Partial.head as)
as' = Partial.tail as
instance AFunctor Many_ c as => AFunctor Many c as where
afmap c m = fromMany_ (afmap c (toMany_ m))
type Collect c r (xs :: [Type]) = (AFoldable (Collector c xs) r, Case (c r) xs)
forMany :: Collect c r xs => c r xs -> Many xs -> Collector c xs r
forMany c (Many xs) = Collector c (toList xs)
collect :: (Collect c r xs) => Many xs -> c r xs -> Collector c xs r
collect = flip forMany
data CollectorN c (n :: Nat) (xs :: [Type]) r = CollectorN (c r n xs) [Any]
instance AFoldable (CollectorN c n '[]) r where
afoldr _ z _ = z
instance ( Case (c r n) (x ': xs)
, ReiterateN (c r) n (x ': xs)
, AFoldable (CollectorN c (n + 1) xs) r
, r ~ CaseResult (c r n) x
) =>
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
v = unsafeCoerce $ Partial.head xs
xs' = Partial.tail xs
type CollectN c r (n :: Nat) (xs :: [Type]) = (AFoldable (CollectorN c n xs) r, Case (c r n) xs)
forManyN :: CollectN c r n xs => c r n xs -> Many xs -> CollectorN c n xs r
forManyN c (Many xs) = CollectorN c (toList xs)
collectN :: CollectN c r n xs => Many xs -> c r n xs -> CollectorN c n xs r
collectN = flip forManyN
type Select (smaller :: [Type]) (larger :: [Type]) =
(AFoldable
(CollectorAny (CaseSelect smaller larger) larger) (Maybe (Int, WrappedAny)))
select :: forall smaller larger. Select smaller larger => Many larger -> Many smaller
select t = Many (fromList' xs')
where
xs' = afoldr (\a z -> maybe z (: z) a) [] (forMany' (CaseSelect @smaller @larger @_ @larger) t)
data CaseSelect (smaller :: [Type]) (larger :: [Type]) r (xs :: [Type]) = CaseSelect
type instance CaseResult (CaseSelect smaller larger r) x = r
instance Reiterate (CaseSelect smaller larger r) (x ': xs) where
reiterate = coerce
instance forall smaller larger x xs n. (UniqueIfExists smaller x larger, MaybeUniqueMemberAt n x smaller) =>
CaseAny (CaseSelect smaller larger (Maybe (Int, WrappedAny))) (x ': xs) where
caseAny _ v =
case i of
0 -> Nothing
i' -> Just (i' 1, WrappedAny v)
where
i = fromInteger (natVal @n Proxy)
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
type SelectN (ns :: [Nat]) (smaller ::[Type]) (larger :: [Type]) =
( AFoldable (CollectorAnyN (CaseSelectN ns smaller) 0 larger) (Maybe (Int, 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 (fromList' xs')
where
xs' = afoldr (\a z -> maybe z (: z) a) [] (forManyN' (CaseSelectN @ns @smaller @_ @0 @larger) xs)
data CaseSelectN (indices :: [Nat]) (smaller :: [Type]) r (n :: Nat) (xs :: [Type]) = CaseSelectN
type instance CaseResult (CaseSelectN indices smaller r n) x = r
instance ReiterateN (CaseSelectN indices smaller r) n (x ': xs) where
reiterateN CaseSelectN = CaseSelectN
instance forall indices smaller n x xs n'. (MaybeMemberAt n' x smaller, n' ~ PositionOf n indices) =>
CaseAny (CaseSelectN indices smaller (Maybe (Int, WrappedAny)) n) (x ': xs) where
caseAny _ v =
case i of
0 -> Nothing
i' -> Just (i' 1, WrappedAny v)
where
i = fromInteger (natVal @n' Proxy)
type Amend smaller larger = (AFoldable (CollectorAny (CaseAmend larger) smaller) (Int, WrappedAny), IsDistinct smaller)
amend :: forall smaller larger. Amend smaller larger => Many larger -> Many smaller -> Many larger
amend (Many ls) t = Many $ foldr (\(i, WrappedAny v) ys -> S.update i v ys) ls xs'
where
xs' = afoldr (:) [] (forMany' (CaseAmend @larger @_ @smaller) t)
data CaseAmend (larger :: [Type]) r (xs :: [Type]) = CaseAmend
type instance CaseResult (CaseAmend larger r) x = r
instance Reiterate (CaseAmend larger r) (x ': xs) where
reiterate = coerce
instance UniqueMemberAt n x larger =>
CaseAny (CaseAmend larger (Int, WrappedAny)) (x ': xs) where
caseAny _ v = (i, WrappedAny v)
where
i = fromInteger (natVal @n Proxy)
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)
type Amend' smaller smaller' larger =
( AFoldable (CollectorAny (CaseAmend' larger) (Zip smaller smaller')) (Int, WrappedAny)
, IsDistinct smaller)
amend' :: forall smaller smaller' larger proxy. Amend' smaller smaller' larger
=> proxy smaller -> Many larger -> Many smaller' -> Many (Replaces smaller smaller' larger)
amend' _ (Many ls) t = Many $ foldr (\(i, WrappedAny v) ys -> S.update i v ys) ls xs'
where
xs' = afoldr (:) [] (forMany'' @smaller Proxy (CaseAmend' @larger @_ @(Zip smaller smaller')) t)
forMany'' :: Proxy xs -> c r (Zip xs ys) -> Many ys -> CollectorAny c (Zip xs ys) r
forMany'' _ c (Many ys) = CollectorAny c (toList ys)
data CaseAmend' (larger :: [Type]) r (zs :: [Type]) = CaseAmend'
type instance CaseResult (CaseAmend' larger r) x = r
instance Reiterate (CaseAmend' larger r) (z ': zs) where
reiterate = coerce
instance (UniqueMemberAt n x larger) =>
CaseAny (CaseAmend' larger (Int, WrappedAny)) ((x, y) ': zs) where
caseAny _ v = (i, WrappedAny v)
where
i = fromInteger (natVal @n Proxy)
amendL'
:: forall ls smaller smaller' larger proxy.
( Amend' smaller smaller' larger
, 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
type AmendN ns smaller larger =
( AFoldable (CollectorAnyN (CaseAmendN ns larger) 0 smaller) (Int, 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 ls) t = Many $ foldr (\(i, WrappedAny v) ys -> S.update i v ys) ls xs'
where
xs' = afoldr (:) [] (forManyN' (CaseAmendN @ns @larger @_ @0 @smaller) t)
data CaseAmendN (indices :: [Nat]) (larger :: [Type]) r (n :: Nat) (xs :: [Type]) = CaseAmendN
type instance CaseResult (CaseAmendN indices larger r n) x = r
instance ReiterateN (CaseAmendN indices larger r) n (x ': xs) where
reiterateN = coerce
instance (MemberAt n' x larger, n' ~ KindAtIndex n indices) =>
CaseAny (CaseAmendN indices larger (Int, WrappedAny) n) (x ': xs) where
caseAny _ v = (i, WrappedAny v)
where
i = fromInteger (natVal @n' Proxy)
type AmendN' ns smaller smaller' larger =
( AFoldable (CollectorAnyN (CaseAmendN' ns larger) 0 (Zip smaller smaller')) (Int, 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 ls) t = Many $ foldr (\(i, WrappedAny v) ys -> S.update i v ys) ls xs'
where
xs' = afoldr (:) [] (forManyN'' @smaller Proxy (CaseAmendN' @ns @larger @_ @0 @(Zip smaller smaller')) t)
forManyN'' :: Proxy xs -> c r n (Zip xs ys) -> Many ys -> CollectorAnyN c n (Zip xs ys) r
forManyN'' _ c (Many ys) = CollectorAnyN c (toList ys)
data CaseAmendN' (indices :: [Nat]) (larger :: [Type]) r (n :: Nat) (zs :: [Type]) = CaseAmendN'
type instance CaseResult (CaseAmendN' indices larger r n) x = r
instance ReiterateN (CaseAmendN' indices larger r) n (z ': zs) where
reiterateN = coerce
instance (MemberAt n' x larger, n' ~ KindAtIndex n indices) =>
CaseAny (CaseAmendN' indices larger (Int, WrappedAny) n) ((x, y) ': zs) where
caseAny _ v = (i, WrappedAny v)
where
i = fromInteger (natVal @n' Proxy)
instance Eq (Many_ '[]) where
_ == _ = True
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)
instance Eq (Many_ xs) => Eq (Many xs) where
lt == rt = toMany_ lt == toMany_ rt
instance Ord (Many_ '[]) where
compare _ _ = EQ
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)
instance Ord (Many_ xs) => Ord (Many xs) where
compare xs ys = compare (toMany_ xs) (toMany_ ys)
instance Semigroup (Many_ '[]) where
_ <> _ = Many_ []
instance (Semigroup x, Semigroup (Many_ xs)) => Semigroup (Many_ (x ': xs)) where
Many_ (a : as) <> Many_ (b : bs) = Many_ (c : cs)
where
c = unsafeCoerce (unsafeCoerce a <> (unsafeCoerce b :: x))
cs = getMany_ (Many_ @xs as <> Many_ @xs bs)
_ <> _ = error "invalid Many_ Semigroup"
instance Semigroup (Many_ xs) => Semigroup (Many xs) where
as <> bs = fromMany_ (toMany_ as <> toMany_ bs)
instance Monoid (Many_ '[]) where
mempty = Many_ []
mappend = (<>)
instance (Monoid x, Monoid (Many_ xs)) => Monoid (Many_ (x ': xs)) where
mempty = Many_ (c : cs)
where
c = unsafeCoerce (mempty :: x)
cs = getMany_ (mempty :: Many_ xs)
Many_ (a : as) `mappend` Many_ (b : bs) = Many_ (c : cs)
where
c = unsafeCoerce (unsafeCoerce a `mappend` (unsafeCoerce b :: x))
cs = getMany_ (Many_ @xs as `mappend` Many_ @xs bs)
_ `mappend` _ = error "invalid Many_ Monoid"
instance Monoid (Many_ xs) => Monoid (Many xs) where
mempty = fromMany_ (mempty :: Many_ xs)
as `mappend` bs = fromMany_ (toMany_ as `mappend` toMany_ bs)
instance Show (Many_ '[]) where
showsPrec d _ = showParen (d > app_prec) $ showString "nil"
where
app_prec = 10
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)
where
cons_prec = 5
v = unsafeCoerce (Partial.head xs) :: x
instance Show (Many_ xs) => Show (Many xs) where
showsPrec d xs = showsPrec d (toMany_ xs)
instance Read (Many_ '[]) where
readPrec = parens $ prec app_prec $ do
lift $ L.expect (Ident "nil")
pure $ Many_ []
where
app_prec = 10
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 "./")
as <- readPrec @(Many_ xs)
pure $ prefix_ a as
where
cons_prec = 5
instance Read (Many_ xs) => Read (Many xs) where
readPrec = do
xs <- readPrec @(Many_ xs)
pure $ fromMany_ xs
newtype WrappedAny = WrappedAny Any