{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Unsafe #-}
{-# LANGUAGE ViewPatterns #-}
module Data.IORef.AtomicModify.Generic
( atomicModifyIORef2Native
) where
import Data.Kind (Constraint, Type)
import GHC.Generics
import GHC.IORef (IORef (..))
#if MIN_VERSION_base(4,13,0)
import GHC.STRef (STRef (..))
import GHC.Exts (atomicModifyMutVar2#)
#else
import Data.IORef.AtomicModify.Generic.UnsafeToPair (unsafeToPair, unsafeFromPair)
import Data.IORef.AtomicModify (atomicModifyIORef3General)
#endif
import GHC.TypeLits
import GHC.IO (IO (..))
type family EnsureGenericData t where
EnsureGenericData t = EnsureGeneric' t (Rep t)
(TypeError ('Text "Could not calculate " :<>: 'ShowType (Rep t) :$$:
'Text "Is it an instance of " :<>: 'ShowType Generic :<>: 'Text "?"))
type family EnsureGeneric' t (rep :: Type -> Type) err :: Constraint where
EnsureGeneric' t (M1 _ ('MetaData _ _ _ 'True) f) _ = TypeError ('ShowType t :<>: 'Text " is a newtype.")
EnsureGeneric' _ _ _ = ()
atomicModifyIORef2Native
:: (EnsureGenericData t, FirstField t (Rep t) ~ a) => IORef a -> (a -> t) -> IO (a, t)
#if MIN_VERSION_base(4,13,0)
atomicModifyIORef2Native :: forall t a.
(EnsureGenericData t, FirstField t (Rep t) ~ a) =>
IORef a -> (a -> t) -> IO (a, t)
atomicModifyIORef2Native (IORef (STRef MutVar# RealWorld a
ref)) a -> t
f = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
case forall d a c.
MutVar# d a -> (a -> c) -> State# d -> (# State# d, a, c #)
atomicModifyMutVar2# MutVar# RealWorld a
ref a -> t
f State# RealWorld
s of
(# State# RealWorld
s', a
old, !t
r #) -> (# State# RealWorld
s', (a
old, t
r) #)
#else
atomicModifyIORef2Native ref f = do
(old, _new, unsafeFromPair -> !r) <- atomicModifyIORef3General ref (\(a, _) -> a) (unsafeToPair . f)
pure (old, r)
#endif
type family FirstField t rep where
FirstField t (M1 _ ('MetaSel _ _ _ 'DecidedUnpack) f) =
TypeError ('Text "The first field of " :<>: 'ShowType t :<>: 'Text " is unpacked")
FirstField t (M1 i c f) = FirstField t f
FirstField t (_ :+: _) = TypeError ('ShowType t :<>: 'Text " is not a record type")
FirstField t (f :*: _) = FirstField t f
FirstField _ (K1 i c) = c
FirstField t V1 = TypeError ('ShowType t :<>: 'Text " has no constructors")
FirstField t U1 = TypeError ('ShowType t :<>: 'Text " has no fields")