{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Diverse.Many.Internal (
Many(..)
, IsMany(..)
, fromMany'
, toMany'
, nil
, single
, consMany
, (./)
, snocMany
, snocMany'
, (\.)
, append
, (/./)
, viewf
, viewb
, front
, back
, aft
, fore
, grab
, grabL
, grabTag
, grabN
, replace
, replace'
, replaceL
, replaceL'
, replaceTag
, replaceTag'
, 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
) where
import Control.Applicative
import Control.DeepSeq
import Data.Bool
import Data.Diverse.AFoldable
import Data.Diverse.AFunctor
import Data.Diverse.ATraversable
import Data.Diverse.Case
import Data.Diverse.Reiterate
import Data.Diverse.TypeLevel
import Data.Foldable
import Data.Kind
import Data.Proxy
import Data.Semigroup (Semigroup(..))
import qualified Data.Sequence as S
import Data.Tagged
import GHC.Exts (Any, coerce)
import qualified GHC.Generics as G
import GHC.TypeLits
import Text.ParserCombinators.ReadPrec
import Text.Read
import qualified Text.Read.Lex as L
import Unsafe.Coerce
import Data.Hashable (Hashable)
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 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 (grab @a r)
instance IsMany Tagged '[a,b] (a,b) where
toMany (Tagged (a,b)) = a./b./nil
fromMany r = Tagged (grabN @0 r, grabN @1 r)
instance IsMany Tagged '[a,b,c] (a,b,c) where
toMany (Tagged (a,b,c)) = a./b./c./nil
fromMany r = Tagged (grabN @0 r, grabN @1 r, grabN @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 (grabN @0 r, grabN @1 r, grabN @2 r, grabN @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 (grabN @0 r, grabN @1 r, grabN @2 r, grabN @3 r, grabN @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 ( grabN @0 r, grabN @1 r, grabN @2 r, grabN @3 r, grabN @4 r
, grabN @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 ( grabN @0 r, grabN @1 r, grabN @2 r, grabN @3 r, grabN @4 r
, grabN @5 r, grabN @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 ( grabN @0 r, grabN @1 r, grabN @2 r, grabN @3 r, grabN @4 r
, grabN @5 r, grabN @6 r, grabN @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 ( grabN @0 r, grabN @1 r, grabN @2 r, grabN @3 r, grabN @4 r
, grabN @5 r, grabN @6 r, grabN @7 r, grabN @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 ( grabN @0 r, grabN @1 r, grabN @2 r, grabN @3 r, grabN @4 r
, grabN @5 r, grabN @6 r, grabN @7 r, grabN @8 r, grabN @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 ( grabN @0 r, grabN @1 r, grabN @2 r, grabN @3 r, grabN @4 r
, grabN @5 r, grabN @6 r, grabN @7 r, grabN @8 r, grabN @9 r
, grabN @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 ( grabN @0 r, grabN @1 r, grabN @2 r, grabN @3 r, grabN @4 r
, grabN @5 r, grabN @6 r, grabN @7 r, grabN @8 r, grabN @9 r
, grabN @10 r, grabN @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 ( grabN @0 r, grabN @1 r, grabN @2 r, grabN @3 r, grabN @4 r
, grabN @5 r, grabN @6 r, grabN @7 r, grabN @8 r, grabN @9 r
, grabN @10 r, grabN @11 r, grabN @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 ( grabN @0 r, grabN @1 r, grabN @2 r, grabN @3 r, grabN @4 r
, grabN @5 r, grabN @6 r, grabN @7 r, grabN @8 r, grabN @9 r
, grabN @10 r, grabN @11 r, grabN @12 r, grabN @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 ( grabN @0 r, grabN @1 r, grabN @2 r, grabN @3 r, grabN @4 r
, grabN @5 r, grabN @6 r, grabN @7 r, grabN @8 r, grabN @9 r
, grabN @10 r, grabN @11r, grabN @12 r, grabN @13 r, grabN @14 r)
nil :: Many '[]
nil = Many S.empty
single :: x -> Many '[x]
single v = Many (S.singleton (unsafeCoerce v))
consMany :: x -> Many xs -> Many (x ': xs)
consMany x (Many rs) = Many ((unsafeCoerce x) S.<| rs)
infixr 5 `consMany`
consMany_ :: x -> Many_ xs -> Many_ (x ': xs)
consMany_ x (Many_ xs) = Many_ (unsafeCoerce x : xs)
(./) :: x -> Many xs -> Many (x ': xs)
(./) = consMany
infixr 5 ./
snocMany :: Many xs -> y -> Many (Append xs '[y])
snocMany (Many ls) y = Many (ls S.|> (unsafeCoerce y))
infixl 5 `snocMany`
snocMany'
:: forall y xs.
MaybeUniqueMember y xs
=> Many xs -> y -> Many (SnocUnique xs y)
snocMany'(Many ls) y = if i /= 0 then Many ls else Many (ls S.|> unsafeCoerce y)
where
i = natToInt @(PositionOf y xs) :: Int
infixl 5 `snocMany'`
(\.) :: Many xs -> y -> Many (Append xs '[y])
(\.) = snocMany
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`
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
grab :: forall x xs. UniqueMember x xs => Many xs -> x
grab (Many xs) = unsafeCoerce $ grab_ @(IndexOf x xs) xs
grab_ :: forall n. NatToInt n => S.Seq Any -> Any
grab_ xs = let !x = S.index xs i in x
where i = natToInt @n
grabL :: forall l x xs. (UniqueLabelMember l xs, x ~ KindAtLabel l xs) => Many xs -> x
grabL (Many xs) = unsafeCoerce $ grab_ @(IndexOf x xs) xs
grabTag :: forall l x xs. (UniqueMember (Tagged l x) xs)
=> Many xs -> x
grabTag xs = unTagged (grab @(Tagged l x) xs)
grabN :: forall n x xs. MemberAt n x xs => Many xs -> x
grabN (Many xs) = unsafeCoerce $ grab_ @n xs
replace' :: forall x xs. UniqueMember x xs => Many xs -> x -> Many xs
replace' (Many xs) x = Many $ replace_ @(IndexOf x xs) xs (unsafeCoerce x)
replace_ :: forall n. NatToInt n => S.Seq Any -> Any -> S.Seq Any
replace_ xs x = S.update i x xs
where i = natToInt @n
replace :: forall x y xs. UniqueMember x xs => Many xs -> y -> Many (Replace x y xs)
replace (Many xs) x = Many $ replace_ @(IndexOf x xs) xs (unsafeCoerce x)
replaceL' :: forall l x xs. (UniqueLabelMember l xs, x ~ KindAtLabel l xs)
=> Many xs -> x -> Many xs
replaceL' (Many xs) x = Many $ replace_ @(IndexOf x xs) xs (unsafeCoerce x)
replaceL :: forall l y xs x. (UniqueLabelMember l xs, x ~ KindAtLabel l xs)
=> Many xs -> y -> Many (Replace x y xs)
replaceL (Many xs) y = Many $ replace_ @(IndexOf x xs) xs (unsafeCoerce y)
replaceTag' :: forall l xs x. (UniqueMember (Tagged l x) xs)
=> Many xs -> x -> Many xs
replaceTag' xs x = replace' @(Tagged l x) xs (Tagged @l x)
replaceTag :: forall l x y xs. (UniqueMember (Tagged l x) xs)
=> Many xs -> y -> Many (Replace (Tagged l x) (Tagged l y) xs)
replaceTag xs y = replace @(Tagged l x) xs (Tagged @l y)
replaceN' :: forall n x xs. MemberAt n x xs => Many xs -> x -> Many xs
replaceN' (Many xs) x = Many $ replace_ @n xs (unsafeCoerce x)
replaceN :: forall n x y xs. MemberAt n x xs => Many xs -> y -> Many (ReplaceIndex n x y xs)
replaceN (Many xs) x = Many $ replace_ @n xs (unsafeCoerce x)
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
{-# INLINABLE afoldr #-}
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
{-# INLINABLE afoldr #-}
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
{-# INLINABLE afoldr #-}
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
{-# INLINABLE afmap #-}
instance AFunctor Many_ c as => AFunctor Many c as where
afmap c m = fromMany_ (afmap c (toMany_ m))
instance ATraversable Many_ c m '[] where
atraverse _ = pure
instance ( Reiterate (c m) (a ': as)
, ATraversable Many_ c m as
, Case (c m) (a ': as)
) =>
ATraversable Many_ c m (a ': as) where
atraverse c (Many_ as) =
Many_ <$>
liftA2 (:)
(unsafeCoerce (case' c a))
(runMany_ <$> atraverse (reiterate c) (Many_ as' :: Many_ as))
where
a = unsafeCoerce (Partial.head as)
as' = Partial.tail as
{-# INLINABLE atraverse #-}
instance ATraversable Many_ c m as => ATraversable Many c m as where
atraverse c m = fromMany_ <$> (atraverse 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
{-# INLINABLE afoldr #-}
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. (UniqueIfExists smaller x larger, MaybeUniqueMember 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 = natToInt @(PositionOf x smaller)
selectL
:: forall ls smaller larger.
( Select smaller larger
, smaller ~ KindsAtLabels ls larger
, IsDistinct ls
, UniqueLabels ls larger)
=> 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.
SelectN ns smaller larger
=> 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 = natToInt @n'
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 UniqueMember x larger =>
CaseAny (CaseAmend' larger (Int, WrappedAny)) (x ': xs) where
caseAny _ v = (i, WrappedAny v)
where
i = natToInt @(IndexOf x larger)
amendL'
:: forall ls smaller larger.
( Amend' smaller larger
, smaller ~ KindsAtLabels ls larger
, IsDistinct ls
, UniqueLabels ls larger)
=> 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 larger'. (Amend smaller smaller' larger, larger' ~ Replaces smaller 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'' @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 (UniqueMember x larger) =>
CaseAny (CaseAmend larger (Int, WrappedAny)) ((x, y) ': zs) where
caseAny _ v = (i, WrappedAny v)
where
i = natToInt @(IndexOf x larger)
amendL
:: forall ls smaller smaller' larger larger'.
( Amend smaller smaller' larger
, smaller ~ KindsAtLabels ls larger
, IsDistinct ls
, UniqueLabels ls larger
, larger' ~ Replaces smaller smaller' larger
)
=> Many larger
-> Many smaller'
-> Many larger'
amendL = amend @(KindsAtLabels ls larger)
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.
(AmendN' ns smaller larger)
=> 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 = natToInt @n'
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 larger'.
(AmendN ns smaller smaller' larger, larger' ~ ReplacesIndex ns smaller' larger)
=> 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'' @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 = natToInt @n'
instance Eq (Many_ '[]) where
_ == _ = True
instance (Eq x, Eq (Many_ xs)) => Eq (Many_ (x ': xs)) where
ls == rs = (front_ ls == front_ rs) && (aft_ ls == aft_ rs)
{-# INLINABLE (==) #-}
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)
{-# INLINABLE compare #-}
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
{-# INLINABLE showsPrec #-}
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 $ consMany_ a as
where
cons_prec = 5
{-# INLINABLE readPrec #-}
instance Read (Many_ xs) => Read (Many xs) where
readPrec = do
xs <- readPrec @(Many_ xs)
pure $ fromMany_ xs
instance NFData (Many '[]) where
rnf _ = ()
instance (NFData x, NFData (Many xs)) => NFData (Many (x ': xs)) where
rnf xs = rnf (front xs) `seq` rnf (aft xs)
instance Hashable (Many '[])
instance (Eq (Many_ xs), Hashable x, Hashable (Many xs)) => Hashable (Many (x ': xs))
newtype WrappedAny = WrappedAny Any