{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE UnboxedTuples       #-}
{-# OPTIONS_HADDOCK not-home #-}
-- |
-- Copyright: (c) 2021 Xy Ren
-- License: BSD3
-- Maintainer: xy.r@outlook.com
-- Stability: unstable
-- Portability: non-portable (GHC only)
--
-- This module defines an immutable extensible record type, similar to @vinyl@ and @data-diverse@. However this
-- implementation focuses on fast reads, hence has very different performance characteristics from other libraries:
--
-- * Lookup: Amortized \( O(1) \).
-- * Update: \( O(n) \).
-- * Shrink: \( O(1) \).
-- * Append: \( O(n) \).
--
-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be
-- extra careful if you're to depend on this module.
module Cleff.Internal.Rec
  ( HandlerPtr (HandlerPtr, unHandlerPtr)
  , Rec
  , type (++)
    -- * Construction
  , empty
  , cons
  , concat
    -- * Deconstruction
  , KnownList
  , head
  , take
  , tail
  , drop
    -- * Retrieval and updating
  , (:>)
  , Subset
  , index
  , pick
  , update
  ) where

import           Cleff.Internal
import           Data.Primitive.PrimArray (MutablePrimArray (MutablePrimArray), PrimArray (PrimArray), copyPrimArray,
                                           indexPrimArray, newPrimArray, writePrimArray)
import           GHC.Exts                 (runRW#, unsafeFreezeByteArray#)
import           GHC.ST                   (ST (ST))
import           GHC.TypeLits             (ErrorMessage (ShowType, Text, (:<>:)), TypeError)
import           Prelude                  hiding (concat, drop, head, tail, take)

-- | A pointer to an effect handler.
type role HandlerPtr nominal
newtype HandlerPtr (e :: Effect) = HandlerPtr { HandlerPtr e -> Int
unHandlerPtr :: Int }

-- | Extensible record type supporting efficient \( O(1) \) reads. The underlying implementation is 'PrimArray'
-- slices.
type role Rec nominal
data Rec (es :: [Effect]) = Rec
  {-# UNPACK #-} !Int -- ^ The offset.
  {-# UNPACK #-} !Int -- ^ The length.
  {-# UNPACK #-} !(PrimArray Int) -- ^ The array content.

unreifiable :: String -> String -> String -> a
unreifiable :: String -> String -> String -> a
unreifiable String
clsName String
funName String
comp = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
  String
funName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": Attempting to access " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
comp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" without a reflected value. This is perhaps because you are trying \
  \to define an instance for the '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
clsName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' typeclass, which you should not be doing whatsoever. If that or \
  \other shenanigans seem unlikely, please report this as a bug."

runPrimArray :: (∀ s. ST s (MutablePrimArray s a)) -> PrimArray a
runPrimArray :: (forall s. ST s (MutablePrimArray s a)) -> PrimArray a
runPrimArray (ST f) = let
  !(# State# RealWorld
_, ByteArray#
ba# #) = (State# RealWorld -> (# State# RealWorld, ByteArray# #))
-> (# State# RealWorld, ByteArray# #)
forall o. (State# RealWorld -> o) -> o
runRW# \State# RealWorld
s1 ->
    let !(# State# RealWorld
s2, MutablePrimArray MutableByteArray# RealWorld
mba# #) = STRep RealWorld (MutablePrimArray RealWorld a)
f State# RealWorld
s1
    in MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba# State# RealWorld
s2
  in ByteArray# -> PrimArray a
forall a. ByteArray# -> PrimArray a
PrimArray ByteArray#
ba#

-- | Create an empty record. \( O(1) \).
empty :: Rec '[]
empty :: Rec '[]
empty = Int -> Int -> PrimArray Int -> Rec '[]
forall (es :: [Effect]). Int -> Int -> PrimArray Int -> Rec es
Rec Int
0 Int
0 (PrimArray Int -> Rec '[]) -> PrimArray Int -> Rec '[]
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (MutablePrimArray s Int)) -> PrimArray Int
forall a. (forall s. ST s (MutablePrimArray s a)) -> PrimArray a
runPrimArray ((forall s. ST s (MutablePrimArray s Int)) -> PrimArray Int)
-> (forall s. ST s (MutablePrimArray s Int)) -> PrimArray Int
forall a b. (a -> b) -> a -> b
$ Int -> ST s (MutablePrimArray (PrimState (ST s)) Int)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
0

-- | Prepend one entry to the record. \( O(n) \).
cons :: HandlerPtr e -> Rec es -> Rec (e : es)
cons :: HandlerPtr e -> Rec es -> Rec (e : es)
cons HandlerPtr e
x (Rec Int
off Int
len PrimArray Int
arr) = Int -> Int -> PrimArray Int -> Rec (e : es)
forall (es :: [Effect]). Int -> Int -> PrimArray Int -> Rec es
Rec Int
0 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (PrimArray Int -> Rec (e : es)) -> PrimArray Int -> Rec (e : es)
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (MutablePrimArray s Int)) -> PrimArray Int
forall a. (forall s. ST s (MutablePrimArray s a)) -> PrimArray a
runPrimArray do
  MutablePrimArray s Int
marr <- Int -> ST s (MutablePrimArray (PrimState (ST s)) Int)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  MutablePrimArray (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
marr Int
0 (HandlerPtr e -> Int
forall (e :: Effect). HandlerPtr e -> Int
unHandlerPtr HandlerPtr e
x)
  MutablePrimArray (PrimState (ST s)) Int
-> Int -> PrimArray Int -> Int -> Int -> ST s ()
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
marr Int
1 PrimArray Int
arr Int
off Int
len
  MutablePrimArray s Int -> ST s (MutablePrimArray s Int)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MutablePrimArray s Int
marr

-- | Concatenate two records. \( O(m+n) \).
concat :: Rec es -> Rec es' -> Rec (es ++ es')
concat :: Rec es -> Rec es' -> Rec (es ++ es')
concat (Rec Int
off Int
len PrimArray Int
arr) (Rec Int
off' Int
len' PrimArray Int
arr') = Int -> Int -> PrimArray Int -> Rec (es ++ es')
forall (es :: [Effect]). Int -> Int -> PrimArray Int -> Rec es
Rec Int
0 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len') (PrimArray Int -> Rec (es ++ es'))
-> PrimArray Int -> Rec (es ++ es')
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (MutablePrimArray s Int)) -> PrimArray Int
forall a. (forall s. ST s (MutablePrimArray s a)) -> PrimArray a
runPrimArray do
  MutablePrimArray s Int
marr <- Int -> ST s (MutablePrimArray (PrimState (ST s)) Int)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len')
  MutablePrimArray (PrimState (ST s)) Int
-> Int -> PrimArray Int -> Int -> Int -> ST s ()
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
marr Int
0 PrimArray Int
arr Int
off Int
len
  MutablePrimArray (PrimState (ST s)) Int
-> Int -> PrimArray Int -> Int -> Int -> ST s ()
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
marr Int
len PrimArray Int
arr' Int
off' Int
len'
  MutablePrimArray s Int -> ST s (MutablePrimArray s Int)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MutablePrimArray s Int
marr

-- | Slice off one entry from the top of the record. \( O(1) \).
tail :: Rec (e : es) -> Rec es
tail :: Rec (e : es) -> Rec es
tail (Rec Int
off Int
len PrimArray Int
arr) = Int -> Int -> PrimArray Int -> Rec es
forall (es :: [Effect]). Int -> Int -> PrimArray Int -> Rec es
Rec (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) PrimArray Int
arr

-- | @'KnownList' es@ means the list @es@ is concrete, /i.e./ is of the form @'[a1, a2, ..., an]@ instead of a type
-- variable.
class KnownList (es :: [Effect]) where
  -- | Get the length of the list.
  reifyLen :: Int
  reifyLen = String -> String -> String -> Int
forall a. String -> String -> String -> a
unreifiable String
"KnownList" String
"Cleff.Internal.Rec.reifyLen" String
"the length of a type-level list"

instance KnownList '[] where
  reifyLen :: Int
reifyLen = Int
0

instance KnownList es => KnownList (e : es) where
  reifyLen :: Int
reifyLen = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ KnownList es => Int
forall (es :: [Effect]). KnownList es => Int
reifyLen @es

-- | Slice off several entries from the top of the record. \( O(1) \).
drop :: ∀ es es'. KnownList es => Rec (es ++ es') -> Rec es'
drop :: Rec (es ++ es') -> Rec es'
drop (Rec Int
off Int
len PrimArray Int
arr) = Int -> Int -> PrimArray Int -> Rec es'
forall (es :: [Effect]). Int -> Int -> PrimArray Int -> Rec es
Rec (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len') (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len') PrimArray Int
arr
  where len' :: Int
len' = KnownList es => Int
forall (es :: [Effect]). KnownList es => Int
reifyLen @es

-- | Get the head of the record. \( O(1) \).
head :: Rec (e : es) -> HandlerPtr e
head :: Rec (e : es) -> HandlerPtr e
head (Rec Int
off Int
_ PrimArray Int
arr) = Int -> HandlerPtr e
forall (e :: Effect). Int -> HandlerPtr e
HandlerPtr (Int -> HandlerPtr e) -> Int -> HandlerPtr e
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Int -> Int
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Int
arr Int
off

-- | Take elements from the top of the record. \( O(m) \).
take :: ∀ es es'. KnownList es => Rec (es ++ es') -> Rec es
take :: Rec (es ++ es') -> Rec es
take (Rec Int
off Int
_ PrimArray Int
arr) = Int -> Int -> PrimArray Int -> Rec es
forall (es :: [Effect]). Int -> Int -> PrimArray Int -> Rec es
Rec Int
0 Int
len (PrimArray Int -> Rec es) -> PrimArray Int -> Rec es
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (MutablePrimArray s Int)) -> PrimArray Int
forall a. (forall s. ST s (MutablePrimArray s a)) -> PrimArray a
runPrimArray do
  MutablePrimArray s Int
marr <- Int -> ST s (MutablePrimArray (PrimState (ST s)) Int)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
  MutablePrimArray (PrimState (ST s)) Int
-> Int -> PrimArray Int -> Int -> Int -> ST s ()
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
marr Int
0 PrimArray Int
arr Int
off Int
len
  MutablePrimArray s Int -> ST s (MutablePrimArray s Int)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MutablePrimArray s Int
marr
  where len :: Int
len = KnownList es => Int
forall (es :: [Effect]). KnownList es => Int
reifyLen @es

-- | @e ':>' es@ means the effect @e@ is present in the effect stack @es@, and therefore can be 'Cleff.send'ed in an
-- @'Cleff.Eff' es@ computation.
class (e :: Effect) :> (es :: [Effect]) where
  -- | Get the index of the element.
  reifyIndex :: Int
  reifyIndex = String -> String -> String -> Int
forall a. String -> String -> String -> a
unreifiable String
"Elem" String
"Cleff.Internal.Rec.reifyIndex" String
"the index of an element of a type-level list"
infix 0 :>

-- | The element closer to the head takes priority.
instance {-# OVERLAPPING #-} e :> e : es where
  reifyIndex :: Int
reifyIndex = Int
0

instance e :> es => e :> e' : es where
  reifyIndex :: Int
reifyIndex = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (e :> es) => Int
forall (e :: Effect) (es :: [Effect]). (e :> es) => Int
reifyIndex @e @es

type ElemNotFound e = Text "The element '" :<>: ShowType e :<>: Text "' is not present in the constraint"

instance TypeError (ElemNotFound e) => e :> '[] where
  reifyIndex :: Int
reifyIndex = String -> Int
forall a. HasCallStack => String -> a
error
    String
"Cleff.Internal.reifyIndex: Attempting to refer to a nonexistent member. Please report this as a bug."

-- | Get an element in the record. Amortized \( O(1) \).
index :: ∀ e es. e :> es => Rec es -> HandlerPtr e
index :: Rec es -> HandlerPtr e
index (Rec Int
off Int
_ PrimArray Int
arr) = Int -> HandlerPtr e
forall (e :: Effect). Int -> HandlerPtr e
HandlerPtr (Int -> HandlerPtr e) -> Int -> HandlerPtr e
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Int -> Int
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Int
arr (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (e :> es) => Int
forall (e :: Effect) (es :: [Effect]). (e :> es) => Int
reifyIndex @e @es)

-- | @es@ is a subset of @es'@, /i.e./ all elements of @es@ are in @es'@.
class KnownList es => Subset (es :: [Effect]) (es' :: [Effect]) where
  -- | Get a list of indices of the elements.
  reifyIndices :: [Int]
  reifyIndices = String -> String -> String -> [Int]
forall a. String -> String -> String -> a
unreifiable
    String
"Subset" String
"Cleff.Internal.Rec.reifyIndices" String
"the index of multiple elements of a type-level list"

instance Subset '[] es where
  reifyIndices :: [Int]
reifyIndices = []

instance (Subset es es', e :> es') => Subset (e : es) es' where
  reifyIndices :: [Int]
reifyIndices = (e :> es') => Int
forall (e :: Effect) (es :: [Effect]). (e :> es) => Int
reifyIndex @e @es' Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Subset es es' => [Int]
forall (es :: [Effect]) (es' :: [Effect]). Subset es es' => [Int]
reifyIndices @es @es'

-- | Get a subset of the record. Amortized \( O(m) \).
pick :: ∀ es es'. Subset es es' => Rec es' -> Rec es
pick :: Rec es' -> Rec es
pick (Rec Int
off Int
_ PrimArray Int
arr) = Int -> Int -> PrimArray Int -> Rec es
forall (es :: [Effect]). Int -> Int -> PrimArray Int -> Rec es
Rec Int
0 (KnownList es => Int
forall (es :: [Effect]). KnownList es => Int
reifyLen @es) (PrimArray Int -> Rec es) -> PrimArray Int -> Rec es
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (MutablePrimArray s Int)) -> PrimArray Int
forall a. (forall s. ST s (MutablePrimArray s a)) -> PrimArray a
runPrimArray do
  MutablePrimArray s Int
marr <- Int -> ST s (MutablePrimArray (PrimState (ST s)) Int)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (KnownList es => Int
forall (es :: [Effect]). KnownList es => Int
reifyLen @es)
  MutablePrimArray s Int -> Int -> [Int] -> ST s ()
forall s. MutablePrimArray s Int -> Int -> [Int] -> ST s ()
go MutablePrimArray s Int
marr Int
0 (Subset es es' => [Int]
forall (es :: [Effect]) (es' :: [Effect]). Subset es es' => [Int]
reifyIndices @es @es')
  MutablePrimArray s Int -> ST s (MutablePrimArray s Int)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MutablePrimArray s Int
marr
  where
    go :: MutablePrimArray s Int -> Int -> [Int] -> ST s ()
    go :: MutablePrimArray s Int -> Int -> [Int] -> ST s ()
go MutablePrimArray s Int
_ Int
_ [] = () -> ST s ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    go MutablePrimArray s Int
marr Int
newIx (Int
ix : [Int]
ixs) = do
      MutablePrimArray (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
marr Int
newIx (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ PrimArray Int -> Int -> Int
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Int
arr (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ix)
      MutablePrimArray s Int -> Int -> [Int] -> ST s ()
forall s. MutablePrimArray s Int -> Int -> [Int] -> ST s ()
go MutablePrimArray s Int
marr (Int
newIx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int]
ixs

-- | Update an entry in the record. \( O(n) \).
update :: ∀ e es. e :> es => HandlerPtr e -> Rec es -> Rec es
update :: HandlerPtr e -> Rec es -> Rec es
update HandlerPtr e
x (Rec Int
off Int
len PrimArray Int
arr) = Int -> Int -> PrimArray Int -> Rec es
forall (es :: [Effect]). Int -> Int -> PrimArray Int -> Rec es
Rec Int
0 Int
len (PrimArray Int -> Rec es) -> PrimArray Int -> Rec es
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (MutablePrimArray s Int)) -> PrimArray Int
forall a. (forall s. ST s (MutablePrimArray s a)) -> PrimArray a
runPrimArray do
  MutablePrimArray s Int
marr <- Int -> ST s (MutablePrimArray (PrimState (ST s)) Int)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
  MutablePrimArray (PrimState (ST s)) Int
-> Int -> PrimArray Int -> Int -> Int -> ST s ()
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
marr Int
0 PrimArray Int
arr Int
off Int
len
  MutablePrimArray (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
marr ((e :> es) => Int
forall (e :: Effect) (es :: [Effect]). (e :> es) => Int
reifyIndex @e @es) (HandlerPtr e -> Int
forall (e :: Effect). HandlerPtr e -> Int
unHandlerPtr HandlerPtr e
x)
  MutablePrimArray s Int -> ST s (MutablePrimArray s Int)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MutablePrimArray s Int
marr