{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UnboxedTuples #-}
module Control.Lens.Mutable.Internal where
import Control.Concurrent.STM.TMVar (TMVar)
import Control.Lens (Lens')
import Data.Primitive.MutVar (MutVar (..))
import GHC.Conc (TVar (..))
import GHC.Exts (MVar#, RealWorld, State#,
newMVar#, newMutVar#, newTVar#,
putMVar#, readMutVar#, readTVar#,
retry#, takeMVar#, writeMutVar#,
writeTVar#)
import GHC.IORef (IORef (..))
import GHC.MVar (MVar (..))
import GHC.STRef (STRef (..))
import Unsafe.Coerce (unsafeCoerce)
import Control.Lens.Mutable.Types
class AsLens s a ref where
asLens :: ref a -> Lens' s a
instance AsLens (S 'OpST s) a (MutVar s) where
asLens (MutVar var#) f (S s1#) =
let !(# s2#, valr #) = readMutVar# var# s1#
in fmap (\valw -> S (writeMutVar# var# valw s2#)) (f valr)
instance AsLens (S 'OpST s) a (STRef s) where
asLens (STRef var#) f (S s1#) =
let !(# s2#, valr #) = readMutVar# var# s1#
in fmap (\valw -> S (writeMutVar# var# valw s2#)) (f valr)
instance AsLens (S 'OpST RealWorld) a IORef where
asLens (IORef stref) = asLens stref
instance AsLens (S 'OpMVar RealWorld) a MVar where
asLens (MVar var#) f (S s1#) =
let !(# s2#, valr #) = takeMVar# var# s1#
in fmap (\valw -> S (putMVar# var# valw s2#)) (f valr)
instance AsLens (S 'OpSTM RealWorld) a TVar where
asLens (TVar var#) f (S s1#) =
let !(# s2#, valr #) = readTVar# var# s1#
in fmap (\valw -> S (writeTVar# var# valw s2#)) (f valr)
instance AsLens (S 'OpSTM RealWorld) a TMVar where
asLens (tmvar :: TMVar a) f (S s1#) =
let !(TVar var#) = (unsafeCoerce tmvar :: TVar (Maybe a))
!(# s2#, valr' #) = readTVar# var# s1#
valr = case valr' of
Just v -> v
Nothing -> let (# _, a #) = retry# s1# in a
in fmap (\valw -> S (writeTVar# var# (Just valw) s2#)) (f valr)
class AsLens s a ref => Allocable s a ref where
alloc :: a -> s -> (ref a, s)
free :: ref a -> s -> (a, s)
free ref = asLens ref (, error "use-after-free")
isValid :: ref a -> s -> (Bool, s)
isValid ref = asLens ref $ \r -> (r `seq` True, r)
instance Allocable (S 'OpST s) a (MutVar s) where
alloc val (S s1#) =
let !(# s2#, var# #) = newMutVar# val s1# in (MutVar var#, S s2#)
instance Allocable (S 'OpST s) a (STRef s) where
alloc val (S s1#) =
let !(# s2#, var# #) = newMutVar# val s1# in (STRef var#, S s2#)
instance Allocable (S 'OpST RealWorld) a IORef where
alloc val s = let (r, s') = alloc val s in (IORef r, s')
instance Allocable (S 'OpMVar RealWorld) a MVar where
alloc (val :: a) (S s1#) =
let !(# s2#, var# #) =
newMVar# s1# :: (# State# RealWorld, MVar# RealWorld a #)
in (MVar var#, S (putMVar# var# val s2#))
instance Allocable (S 'OpSTM RealWorld) a TVar where
alloc val (S s1#) =
let !(# s2#, var# #) = newTVar# val s1# in (TVar var#, S s2#)
instance Allocable (S 'OpSTM RealWorld) a TMVar where
alloc val (S s1#) =
let !(# s2#, var# #) = newTVar# (Just val) s1#
in (unsafeCoerce (TVar var#), S s2#)