{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Unsafe #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Data.Struct.Internal where
import Control.Exception
import Control.Monad.Primitive
import Control.Monad.ST
import Data.Primitive
import Data.Coerce
import GHC.Exts
#ifdef HLINT
{-# ANN module "HLint: ignore Eta reduce" #-}
{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}
{-# ANN module "HLint: ignore Avoid lambda" #-}
{-# ANN module "HLint: ignore Redundant lambda" #-}
#endif
data NullPointerException = NullPointerException deriving (Show, Exception)
data Dict p where
Dict :: p => Dict p
st :: PrimMonad m => ST (PrimState m) a -> m a
st = primToPrim
{-# INLINE[0] st #-}
class Struct t where
struct :: Dict (Coercible (t s) (Object s))
#ifndef HLINT
default struct :: Coercible (t s) (Object s) => Dict (Coercible (t s) (Object s))
#endif
struct = Dict
{-# MINIMAL #-}
data Object s = Object { runObject :: SmallMutableArray# s Any }
instance Struct Object
coerceF :: Dict (Coercible a b) -> a -> b
coerceF Dict = coerce
{-# INLINE coerceF #-}
coerceB :: Dict (Coercible a b) -> b -> a
coerceB Dict = coerce
{-# INLINE coerceB #-}
destruct :: Struct t => t s -> SmallMutableArray# s Any
destruct = \x -> runObject (coerceF struct x)
{-# INLINE destruct #-}
construct :: Struct t => SmallMutableArray# s Any -> t s
construct = \x -> coerceB struct (Object x)
{-# INLINE construct #-}
unsafeCoerceStruct :: (Struct x, Struct y) => x s -> y s
unsafeCoerceStruct x = construct (destruct x)
eqStruct :: Struct t => t s -> t s -> Bool
eqStruct = \x y -> isTrue# (destruct x `sameSmallMutableArray#` destruct y)
{-# INLINE eqStruct #-}
instance Eq (Object s) where
(==) = eqStruct
#ifndef HLINT
pattern Struct :: Struct t => () => SmallMutableArray# s Any -> t s
pattern Struct x <- (destruct -> x) where
Struct x = construct x
#endif
alloc :: (PrimMonad m, Struct t) => Int -> m (t (PrimState m))
alloc (I# n#) = primitive $ \s -> case newSmallArray# n# undefined s of (# s', b #) -> (# s', construct b #)
data Box = Box Null
data Null = Null
isNil :: Struct t => t s -> Bool
isNil t = isTrue# (unsafeCoerce# reallyUnsafePtrEquality# (destruct t) Null)
{-# INLINE isNil #-}
#ifndef HLINT
pattern Nil :: Struct t => () => t s
pattern Nil <- (isNil -> True) where
Nil = unsafeCoerce# Box Null
#endif
writeSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> SmallMutableArray# s Any -> State# s -> State# s
writeSmallMutableArraySmallArray# m i a s = unsafeCoerce# writeSmallArray# m i a s
{-# INLINE writeSmallMutableArraySmallArray# #-}
readSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> State# s -> (# State# s, SmallMutableArray# s Any #)
readSmallMutableArraySmallArray# m i s = unsafeCoerce# readSmallArray# m i s
{-# INLINE readSmallMutableArraySmallArray# #-}
writeMutableByteArraySmallArray# :: SmallMutableArray# s Any -> Int# -> MutableByteArray# s -> State# s -> State# s
writeMutableByteArraySmallArray# m i a s = unsafeCoerce# writeSmallArray# m i a s
{-# INLINE writeMutableByteArraySmallArray# #-}
readMutableByteArraySmallArray# :: SmallMutableArray# s Any -> Int# -> State# s -> (# State# s, MutableByteArray# s #)
readMutableByteArraySmallArray# m i s = unsafeCoerce# readSmallArray# m i s
{-# INLINE readMutableByteArraySmallArray# #-}
casSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> (# State# s, Int#, SmallMutableArray# s Any #)
casSmallMutableArraySmallArray# m i o n s = unsafeCoerce# casSmallArray# m i o n s
{-# INLINE casSmallMutableArraySmallArray# #-}
data Slot x y = Slot
(forall s. SmallMutableArray# s Any -> State# s -> (# State# s, SmallMutableArray# s Any #))
(forall s. SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> State# s)
(forall s. SmallMutableArray# s Any -> SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> (# State# s, Int#, SmallMutableArray# s Any #))
class Precomposable t where
( # ) :: Slot x y -> t y z -> t x z
instance Precomposable Slot where
Slot gxy _ _ # Slot gyz syz cyz = Slot
(\x s -> case gxy x s of (# s', y #) -> gyz y s')
(\x z s -> case gxy x s of (# s', y #) -> syz y z s')
(\x o n s -> case gxy x s of (# s', y #) -> cyz y o n s')
slot :: Int -> Slot s t
slot (I# i) = Slot
(\m s -> readSmallMutableArraySmallArray# m i s)
(\m a s -> writeSmallMutableArraySmallArray# m i a s)
(\m o n s -> casSmallMutableArraySmallArray# m i o n s)
get :: (PrimMonad m, Struct x, Struct y) => Slot x y -> x (PrimState m) -> m (y (PrimState m))
get (Slot go _ _) = \x -> primitive $ \s -> case go (destruct x) s of
(# s', y #) -> (# s', construct y #)
{-# INLINE get #-}
set :: (PrimMonad m, Struct x, Struct y) => Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set (Slot _ go _) = \x y -> primitive_ (go (destruct x) (destruct y))
{-# INLINE set #-}
cas :: (PrimMonad m, Struct x, Struct y) => Slot x y -> x (PrimState m) -> y (PrimState m) -> y (PrimState m) -> m (Bool, y (PrimState m))
cas (Slot _ _ go) = \m o n -> primitive $ \s -> case go (destruct m) (destruct o) (destruct n) s of
(# s', i, r #) -> (# s', (tagToEnum# i :: Bool, construct r) #)
data Field x a = Field
(forall s. SmallMutableArray# s Any -> State# s -> (# State# s, a #))
(forall s. SmallMutableArray# s Any -> a -> State# s -> State# s)
instance Precomposable Field where
Slot gxy _ _ # Field gyz syz = Field
(\x s -> case gxy x s of (# s', y #) -> gyz y s')
(\x z s -> case gxy x s of (# s', y #) -> syz y z s')
field :: Int -> Field s a
field (I# i) = Field
(\m s -> unsafeCoerce# readSmallArray# m i s)
(\m a s -> unsafeCoerce# writeSmallArray# m i a s)
{-# INLINE field #-}
unboxedField :: Prim a => Int -> Int -> Field s a
unboxedField (I# i) (I# j) = Field
(\m s -> case readMutableByteArraySmallArray# m i s of
(# s', mba #) -> readByteArray# mba j s')
(\m a s -> case readMutableByteArraySmallArray# m i s of
(# s', mba #) -> writeByteArray# mba j a s')
{-# INLINE unboxedField #-}
initializeUnboxedField ::
(PrimMonad m, Struct x) =>
Int ->
Int ->
Int ->
x (PrimState m) ->
m (MutableByteArray (PrimState m))
initializeUnboxedField (I# i) (I# n) (I# z) m =
primitive $ \s ->
case newByteArray# (n *# z) s of
(# s1, mba #) ->
(# writeMutableByteArraySmallArray# (destruct m) i mba s1, MutableByteArray mba #)
{-# INLINE initializeUnboxedField #-}
getField :: (PrimMonad m, Struct x) => Field x a -> x (PrimState m) -> m a
getField (Field go _) = \x -> primitive (go (destruct x))
{-# INLINE getField #-}
setField :: (PrimMonad m, Struct x) => Field x a -> x (PrimState m) -> a -> m ()
setField (Field _ go) = \x y -> primitive_ (go (destruct x) y)
{-# INLINE setField #-}
modifyField :: (Struct x, PrimMonad m) => Field x a -> x (PrimState m) -> (a -> a) -> m ()
modifyField s = \o f -> st (setField s o . f =<< getField s o)
{-# INLINE modifyField #-}
modifyField' :: (Struct x, PrimMonad m) => Field x a -> x (PrimState m) -> (a -> a) -> m ()
modifyField' s = \o f -> st (setField s o =<< (\x -> return $! f x) =<< getField s o)
{-# INLINE modifyField' #-}