{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
#if __GLASGOW_HASKELL__ >= 806
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
#endif
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Vinyl.ARec.Internal
( ARec (..)
, ToARec
, IndexableField
, arec
, ARecBuilder (..)
, arcons
, arnil
, toARec
, fromARec
, aget
, unsafeAput
, unsafeAlens
, arecGetSubset
, arecSetSubset
, arecRepsMatchCoercion
, arecConsMatchCoercion
) where
import Data.Vinyl.Core
import Data.Vinyl.Lens (RecElem(..), RecSubset(..))
import Data.Vinyl.TypeLevel
import Data.Vinyl.ARec.Internal.SmallArray
import Control.Monad.ST
import Unsafe.Coerce
#if __GLASGOW_HASKELL__ < 806
import Data.Constraint.Forall (Forall)
#endif
import Data.Type.Coercion (Coercion (..))
import GHC.Types
newtype ARec (f :: k -> *) (ts :: [k]) = ARec SmallArray
type role ARec representational nominal
unsafeIxARec
:: forall a k (f :: k -> *) (ts :: [k]).
ARec f ts
-> Int
-> a
unsafeIxARec :: forall a k (f :: k -> *) (ts :: [k]). ARec f ts -> Int -> a
unsafeIxARec (ARec SmallArray
ar) Int
ix = forall a. SmallArray -> Int -> a
indexSmallArray SmallArray
ar Int
ix
{-# INLINE unsafeIxARec #-}
arecRepsMatchCoercion :: AllRepsMatch f xs g ys => Coercion (ARec f xs) (ARec g ys)
arecRepsMatchCoercion :: forall {k} {k} (f :: k -> *) (xs :: [k]) (g :: k -> *) (ys :: [k]).
AllRepsMatch f xs g ys =>
Coercion (ARec f xs) (ARec g ys)
arecRepsMatchCoercion = forall a b. a -> b
unsafeCoerce (forall {k} (a :: k) (b :: k). Coercible a b => Coercion a b
Coercion :: Coercion () ())
#if __GLASGOW_HASKELL__ >= 806
arecConsMatchCoercion ::
(forall (x :: k). Coercible (f x) (g x)) => Coercion (ARec f xs) (ARec g xs)
arecConsMatchCoercion :: forall k (f :: k -> *) (g :: k -> *) (xs :: [k]).
(forall (x :: k). Coercible (f x) (g x)) =>
Coercion (ARec f xs) (ARec g xs)
arecConsMatchCoercion = forall a b. a -> b
unsafeCoerce (forall {k} (a :: k) (b :: k). Coercible a b => Coercion a b
Coercion :: Coercion () ())
#else
arecConsMatchCoercion :: forall k (f :: k -> *) (g :: k -> *) (xs :: [k]).
Forall (Similar f g) => Coercion (Rec f xs) (Rec g xs)
arecConsMatchCoercion = unsafeCoerce (Coercion :: Coercion (Rec f xs) (Rec f xs))
#endif
class ToARec (us :: [k]) where
aRecValues :: Rec f us -> ARecBuilder f us
instance ToARec '[] where
aRecValues :: forall (f :: k -> *). Rec f '[] -> ARecBuilder f '[]
aRecValues Rec f '[]
RNil = forall {k} {k} (f :: k). ARecBuilder f '[]
arnil
{-# INLINE aRecValues #-}
instance ToARec us => ToARec (u ': us) where
aRecValues :: forall (f :: k -> *). Rec f (u : us) -> ARecBuilder f (u : us)
aRecValues (f r
x :& Rec f rs
xs) = f r
x forall {a} (f :: a -> *) (u :: a) (us :: [a]).
f u -> ARecBuilder f us -> ARecBuilder f (u : us)
`arcons` forall k (us :: [k]) (f :: k -> *).
ToARec us =>
Rec f us -> ARecBuilder f us
aRecValues Rec f rs
xs
{-# INLINE aRecValues #-}
toARec
:: forall f ts.
(NatToInt (RLength ts), ToARec ts)
=> Rec f ts
-> ARec f ts
toARec :: forall {k} (f :: k -> *) (ts :: [k]).
(NatToInt (RLength ts), ToARec ts) =>
Rec f ts -> ARec f ts
toARec Rec f ts
rs = forall k (us :: [k]) (f :: k -> *).
NatToInt (RLength us) =>
ARecBuilder f us -> ARec f us
arec (forall k (us :: [k]) (f :: k -> *).
ToARec us =>
Rec f us -> ARecBuilder f us
aRecValues Rec f ts
rs)
{-# INLINE toARec #-}
newtype ARecBuilder f us =
ARecBuilder ( forall s.
Int
-> SmallMutableArray s
-> ST s ()
)
infixr 1 `arcons`
arcons :: f u -> ARecBuilder f us -> ARecBuilder f (u ': us)
arcons :: forall {a} (f :: a -> *) (u :: a) (us :: [a]).
f u -> ARecBuilder f us -> ARecBuilder f (u : us)
arcons !f u
v (ARecBuilder forall s. Int -> SmallMutableArray s -> ST s ()
fvs) = forall {k} {k} (f :: k) (us :: k).
(forall s. Int -> SmallMutableArray s -> ST s ())
-> ARecBuilder f us
ARecBuilder forall a b. (a -> b) -> a -> b
$ \Int
i SmallMutableArray s
mArr -> do
forall s a. SmallMutableArray s -> Int -> a -> ST s ()
writeSmallArray SmallMutableArray s
mArr Int
i f u
v
forall s. Int -> SmallMutableArray s -> ST s ()
fvs (Int
iforall a. Num a => a -> a -> a
+Int
1) SmallMutableArray s
mArr
{-# INLINE arcons #-}
arnil :: ARecBuilder f '[]
arnil :: forall {k} {k} (f :: k). ARecBuilder f '[]
arnil = forall {k} {k} (f :: k) (us :: k).
(forall s. Int -> SmallMutableArray s -> ST s ())
-> ARecBuilder f us
ARecBuilder forall a b. (a -> b) -> a -> b
$ \Int
_i SmallMutableArray s
_arr -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE arnil #-}
arec
:: forall k (us :: [k] ) f
. (NatToInt (RLength us)) =>
ARecBuilder f us
-> ARec f us
arec :: forall k (us :: [k]) (f :: k -> *).
NatToInt (RLength us) =>
ARecBuilder f us -> ARec f us
arec (ARecBuilder forall s. Int -> SmallMutableArray s -> ST s ()
fillArray) = forall k (f :: k -> *) (ts :: [k]). SmallArray -> ARec f ts
ARec forall a b. (a -> b) -> a -> b
$
forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ forall s.
Int -> (SmallMutableArray s -> ST s ()) -> ST s SmallArray
withNewSmallArray (forall (n :: Nat). NatToInt n => Int
natToInt @(RLength us))
forall a b. (a -> b) -> a -> b
$ forall s. Int -> SmallMutableArray s -> ST s ()
fillArray Int
0
{-# INLINE arec #-}
class (NatToInt (RIndex t ts)) => IndexableField ts t where
instance (NatToInt (RIndex t ts)) => IndexableField ts t where
fromARec :: forall f ts.
(RecApplicative ts, RPureConstrained (IndexableField ts) ts)
=> ARec f ts -> Rec f ts
fromARec :: forall {u} (f :: u -> *) (ts :: [u]).
(RecApplicative ts, RPureConstrained (IndexableField ts) ts) =>
ARec f ts -> Rec f ts
fromARec ARec f ts
ar = forall {k} (c :: k -> Constraint) (ts :: [k]) (f :: k -> *).
RPureConstrained c ts =>
(forall (a :: k). c a => f a) -> Rec f ts
rpureConstrained @(IndexableField ts) forall (t :: u). NatToInt (RIndex t ts) => f t
aux
where aux :: forall t. NatToInt (RIndex t ts) => f t
aux :: forall (t :: u). NatToInt (RIndex t ts) => f t
aux = forall a k (f :: k -> *) (ts :: [k]). ARec f ts -> Int -> a
unsafeIxARec ARec f ts
ar (forall (n :: Nat). NatToInt n => Int
natToInt @(RIndex t ts))
{-# INLINE fromARec #-}
aget :: forall t f ts. (NatToInt (RIndex t ts)) => ARec f ts -> f t
aget :: forall {k} (t :: k) (f :: k -> *) (ts :: [k]).
NatToInt (RIndex t ts) =>
ARec f ts -> f t
aget ARec f ts
ar = forall a k (f :: k -> *) (ts :: [k]). ARec f ts -> Int -> a
unsafeIxARec ARec f ts
ar (forall (n :: Nat). NatToInt n => Int
natToInt @(RIndex t ts))
{-# INLINE aget #-}
unsafeAput :: forall t t' f ts ts'. (NatToInt (RIndex t ts))
=> f t' -> ARec f ts -> ARec f ts'
unsafeAput :: forall {k} (t :: k) (t' :: k) (f :: k -> *) (ts :: [k])
(ts' :: [k]).
NatToInt (RIndex t ts) =>
f t' -> ARec f ts -> ARec f ts'
unsafeAput f t'
x (ARec SmallArray
arr) = forall k (f :: k -> *) (ts :: [k]). SmallArray -> ARec f ts
ARec forall a b. (a -> b) -> a -> b
$ forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$
forall s.
SmallArray -> (SmallMutableArray s -> ST s ()) -> ST s SmallArray
withThawedSmallArray SmallArray
arr forall a b. (a -> b) -> a -> b
$ \SmallMutableArray s
mArr ->
forall s a. SmallMutableArray s -> Int -> a -> ST s ()
writeSmallArray SmallMutableArray s
mArr (forall (n :: Nat). NatToInt n => Int
natToInt @(RIndex t ts)) f t'
x
{-# INLINE unsafeAput #-}
unsafeAlens :: forall f g t t' ts ts'. (Functor g, NatToInt (RIndex t ts))
=> (f t -> g (f t')) -> ARec f ts -> g (ARec f ts')
unsafeAlens :: forall {k} (f :: k -> *) (g :: * -> *) (t :: k) (t' :: k)
(ts :: [k]) (ts' :: [k]).
(Functor g, NatToInt (RIndex t ts)) =>
(f t -> g (f t')) -> ARec f ts -> g (ARec f ts')
unsafeAlens f t -> g (f t')
f ARec f ts
ar = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall {k} (t :: k) (t' :: k) (f :: k -> *) (ts :: [k])
(ts' :: [k]).
NatToInt (RIndex t ts) =>
f t' -> ARec f ts -> ARec f ts'
unsafeAput @t) ARec f ts
ar) (f t -> g (f t')
f (forall {k} (t :: k) (f :: k -> *) (ts :: [k]).
NatToInt (RIndex t ts) =>
ARec f ts -> f t
aget ARec f ts
ar))
{-# INLINE unsafeAlens #-}
instance RecElem ARec t t' (t ': ts) (t' ': ts) 'Z where
rlensC :: forall (g :: * -> *) (f :: a -> *).
(Functor g, RecElemFCtx ARec f) =>
(f t -> g (f t')) -> ARec f (t : ts) -> g (ARec f (t' : ts))
rlensC = forall {k} (f :: k -> *) (g :: * -> *) (t :: k) (t' :: k)
(ts :: [k]) (ts' :: [k]).
(Functor g, NatToInt (RIndex t ts)) =>
(f t -> g (f t')) -> ARec f ts -> g (ARec f ts')
unsafeAlens
{-# INLINE rlensC #-}
rgetC :: forall (f :: a -> *).
(RecElemFCtx ARec f, t ~ t') =>
ARec f (t : ts) -> f t
rgetC = forall {k} (t :: k) (f :: k -> *) (ts :: [k]).
NatToInt (RIndex t ts) =>
ARec f ts -> f t
aget
{-# INLINE rgetC #-}
rputC :: forall (f :: a -> *).
RecElemFCtx ARec f =>
f t' -> ARec f (t : ts) -> ARec f (t' : ts)
rputC = forall {k} (t :: k) (t' :: k) (f :: k -> *) (ts :: [k])
(ts' :: [k]).
NatToInt (RIndex t ts) =>
f t' -> ARec f ts -> ARec f ts'
unsafeAput @t
{-# INLINE rputC #-}
instance (RIndex t (s ': ts) ~ 'S i, NatToInt i, RecElem ARec t t' ts ts' i)
=> RecElem ARec t t' (s ': ts) (s ': ts') ('S i) where
rlensC :: forall (g :: * -> *) (f :: a -> *).
(Functor g, RecElemFCtx ARec f) =>
(f t -> g (f t')) -> ARec f (s : ts) -> g (ARec f (s : ts'))
rlensC = forall {k} (f :: k -> *) (g :: * -> *) (t :: k) (t' :: k)
(ts :: [k]) (ts' :: [k]).
(Functor g, NatToInt (RIndex t ts)) =>
(f t -> g (f t')) -> ARec f ts -> g (ARec f ts')
unsafeAlens
{-# INLINE rlensC #-}
rgetC :: forall (f :: a -> *).
(RecElemFCtx ARec f, t ~ t') =>
ARec f (s : ts) -> f t
rgetC = forall {k} (t :: k) (f :: k -> *) (ts :: [k]).
NatToInt (RIndex t ts) =>
ARec f ts -> f t
aget
{-# INLINE rgetC #-}
rputC :: forall (f :: a -> *).
RecElemFCtx ARec f =>
f t' -> ARec f (s : ts) -> ARec f (s : ts')
rputC = forall {k} (t :: k) (t' :: k) (f :: k -> *) (ts :: [k])
(ts' :: [k]).
NatToInt (RIndex t ts) =>
f t' -> ARec f ts -> ARec f ts'
unsafeAput @t
{-# INLINE rputC #-}
arecGetSubset :: forall rs ss f.
(IndexWitnesses (RImage rs ss), NatToInt (RLength rs))
=> ARec f ss -> ARec f rs
arecGetSubset :: forall {k} (rs :: [k]) (ss :: [k]) (f :: k -> *).
(IndexWitnesses (RImage rs ss), NatToInt (RLength rs)) =>
ARec f ss -> ARec f rs
arecGetSubset (ARec SmallArray
arr) =
forall k (f :: k -> *) (ts :: [k]). SmallArray -> ARec f ts
ARec forall a b. (a -> b) -> a -> b
$ forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$
forall s.
Int -> (SmallMutableArray s -> ST s ()) -> ST s SmallArray
withNewSmallArray (forall (n :: Nat). NatToInt n => Int
natToInt @(RLength rs)) forall a b. (a -> b) -> a -> b
$ \SmallMutableArray s
mArr ->
forall s. SmallMutableArray s -> Int -> [Int] -> ST s ()
go SmallMutableArray s
mArr Int
0 (forall (is :: [Nat]). IndexWitnesses is => [Int]
indexWitnesses @(RImage rs ss))
where
go :: SmallMutableArray s -> Int -> [Int] -> ST s ()
go :: forall s. SmallMutableArray s -> Int -> [Int] -> ST s ()
go SmallMutableArray s
_mArr Int
_to [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
go SmallMutableArray s
mArr Int
to (Int
from : [Int]
froms) = do
forall s a. SmallMutableArray s -> Int -> a -> ST s ()
writeSmallArray SmallMutableArray s
mArr Int
to (forall a. SmallArray -> Int -> a
indexSmallArray SmallArray
arr Int
from :: Any)
forall s. SmallMutableArray s -> Int -> [Int] -> ST s ()
go SmallMutableArray s
mArr (Int
to forall a. Num a => a -> a -> a
+ Int
1) [Int]
froms
{-# INLINE arecGetSubset #-}
arecSetSubset :: forall rs ss f. (IndexWitnesses (RImage rs ss))
=> ARec f ss -> ARec f rs -> ARec f ss
arecSetSubset :: forall {k} (rs :: [k]) (ss :: [k]) (f :: k -> *).
IndexWitnesses (RImage rs ss) =>
ARec f ss -> ARec f rs -> ARec f ss
arecSetSubset (ARec SmallArray
arrBig) (ARec SmallArray
arrSmall) = forall k (f :: k -> *) (ts :: [k]). SmallArray -> ARec f ts
ARec forall a b. (a -> b) -> a -> b
$ forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$
forall s.
SmallArray -> (SmallMutableArray s -> ST s ()) -> ST s SmallArray
withThawedSmallArray SmallArray
arrBig forall a b. (a -> b) -> a -> b
$ \SmallMutableArray s
mArr -> do
forall s. SmallMutableArray s -> Int -> [Int] -> ST s ()
go SmallMutableArray s
mArr Int
0 (forall (is :: [Nat]). IndexWitnesses is => [Int]
indexWitnesses @(RImage rs ss))
where
go :: SmallMutableArray s -> Int -> [Int] -> ST s ()
go :: forall s. SmallMutableArray s -> Int -> [Int] -> ST s ()
go SmallMutableArray s
_mArr Int
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
go SmallMutableArray s
mArr Int
from (Int
to : [Int]
tos) = do
forall s a. SmallMutableArray s -> Int -> a -> ST s ()
writeSmallArray SmallMutableArray s
mArr Int
to (forall a. SmallArray -> Int -> a
indexSmallArray SmallArray
arrSmall Int
from)
forall s. SmallMutableArray s -> Int -> [Int] -> ST s ()
go SmallMutableArray s
mArr (Int
from forall a. Num a => a -> a -> a
+ Int
1) [Int]
tos
{-# INLINE arecSetSubset #-}
instance (is ~ RImage rs ss, IndexWitnesses is, NatToInt (RLength rs))
=> RecSubset ARec rs ss is where
rsubsetC :: forall (g :: * -> *) (f :: k -> *).
(Functor g, RecSubsetFCtx ARec f) =>
(ARec f rs -> g (ARec f rs)) -> ARec f ss -> g (ARec f ss)
rsubsetC ARec f rs -> g (ARec f rs)
f ARec f ss
big = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} (rs :: [k]) (ss :: [k]) (f :: k -> *).
IndexWitnesses (RImage rs ss) =>
ARec f ss -> ARec f rs -> ARec f ss
arecSetSubset ARec f ss
big) (ARec f rs -> g (ARec f rs)
f (forall {k} (rs :: [k]) (ss :: [k]) (f :: k -> *).
(IndexWitnesses (RImage rs ss), NatToInt (RLength rs)) =>
ARec f ss -> ARec f rs
arecGetSubset ARec f ss
big))
{-# INLINE rsubsetC #-}
instance (RPureConstrained (IndexableField rs) rs,
RecApplicative rs,
Show (Rec f rs)) => Show (ARec f rs) where
show :: ARec f rs -> String
show = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (f :: u -> *) (ts :: [u]).
(RecApplicative ts, RPureConstrained (IndexableField ts) ts) =>
ARec f ts -> Rec f ts
fromARec
instance (RPureConstrained (IndexableField rs) rs,
RecApplicative rs,
Eq (Rec f rs)) => Eq (ARec f rs) where
ARec f rs
x == :: ARec f rs -> ARec f rs -> Bool
== ARec f rs
y = forall {u} (f :: u -> *) (ts :: [u]).
(RecApplicative ts, RPureConstrained (IndexableField ts) ts) =>
ARec f ts -> Rec f ts
fromARec ARec f rs
x forall a. Eq a => a -> a -> Bool
== forall {u} (f :: u -> *) (ts :: [u]).
(RecApplicative ts, RPureConstrained (IndexableField ts) ts) =>
ARec f ts -> Rec f ts
fromARec ARec f rs
y
instance (RPureConstrained (IndexableField rs) rs,
RecApplicative rs,
Ord (Rec f rs)) => Ord (ARec f rs) where
compare :: ARec f rs -> ARec f rs -> Ordering
compare ARec f rs
x ARec f rs
y = forall a. Ord a => a -> a -> Ordering
compare (forall {u} (f :: u -> *) (ts :: [u]).
(RecApplicative ts, RPureConstrained (IndexableField ts) ts) =>
ARec f ts -> Rec f ts
fromARec ARec f rs
x) (forall {u} (f :: u -> *) (ts :: [u]).
(RecApplicative ts, RPureConstrained (IndexableField ts) ts) =>
ARec f ts -> Rec f ts
fromARec ARec f rs
y)