module UNames (NameSupply, Name,
rootSupply, splitSupply, names,
saveRootNameSupply, restoreRootNameSupply, unsafeResetRootNameSupply)
where
import Control.Monad (when)
import Data.Ix
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Binary (Binary(..))
newtype NameSupply = NameSupply (IORef Int)
newtype Name = Name Int
deriving (Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq, Eq Name
Eq Name
-> (Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmax :: Name -> Name -> Name
>= :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c< :: Name -> Name -> Bool
compare :: Name -> Name -> Ordering
$ccompare :: Name -> Name -> Ordering
$cp1Ord :: Eq Name
Ord)
instance Ix Name where
range :: (Name, Name) -> [Name]
range (Name Int
from, Name Int
to) = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
Name ((Int, Int) -> [Int]
forall a. Ix a => (a, a) -> [a]
range (Int
from, Int
to))
index :: (Name, Name) -> Name -> Int
index (Name Int
from, Name Int
to) (Name Int
idx) = (Int, Int) -> Int -> Int
forall a. Ix a => (a, a) -> a -> Int
index (Int
from, Int
to) Int
idx
inRange :: (Name, Name) -> Name -> Bool
inRange (Name Int
from, Name Int
to) (Name Int
idx) = (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
from, Int
to) Int
idx
instance Show Name where
show :: Name -> String
show (Name Int
i) = Int -> String
forall a. Show a => a -> String
show Int
i
rootSupply :: NameSupply
{-# NOINLINE rootSupply #-}
rootSupply :: NameSupply
rootSupply = IORef Int -> NameSupply
NameSupply (Int -> IORef Int
unsafeNewIntRef Int
1)
splitSupply :: NameSupply -> [NameSupply]
splitSupply :: NameSupply -> [NameSupply]
splitSupply NameSupply
s = NameSupply -> [NameSupply]
forall a. a -> [a]
repeat NameSupply
s
names :: NameSupply -> [Name]
names :: NameSupply -> [Name]
names (NameSupply IORef Int
s) =
IORef Int -> [Name]
theNames IORef Int
s
where
theNames :: IORef Int -> [Name]
theNames IORef Int
s = Int -> Name
Name (IORef Int -> Int
unsafeReadAndIncIntRef IORef Int
s) Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: IORef Int -> [Name]
theNames IORef Int
s
saveRootNameSupply :: IO Name
saveRootNameSupply :: IO Name
saveRootNameSupply =
case NameSupply
rootSupply of
NameSupply IORef Int
ref -> do
Int
val <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref Int
0
Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Name
Name Int
val)
restoreRootNameSupply :: Name -> IO ()
restoreRootNameSupply :: Name -> IO ()
restoreRootNameSupply (Name Int
val) =
case NameSupply
rootSupply of
NameSupply IORef Int
ref -> do
Int
prev <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
prev Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (String -> IO ()
forall a. HasCallStack => String -> a
error String
"UName: root name supply used before restoring")
IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref Int
val
unsafeResetRootNameSupply :: IO ()
unsafeResetRootNameSupply :: IO ()
unsafeResetRootNameSupply =
case NameSupply
rootSupply of
NameSupply IORef Int
ref -> IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref Int
1
instance Binary Name where
put_ :: BinHandle -> Name -> IO ()
put_ BinHandle
bh (Name Int
aa) = do
BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
aa
get :: BinHandle -> IO Name
get BinHandle
bh = do
Int
aa <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Name
Name Int
aa)
unsafeNewIntRef :: Int -> IORef Int
unsafeNewIntRef :: Int -> IORef Int
unsafeNewIntRef Int
i = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
i)
unsafeReadAndIncIntRef :: IORef Int -> Int
unsafeReadAndIncIntRef :: IORef Int -> Int
unsafeReadAndIncIntRef IORef Int
mv = IO Int -> Int
forall a. IO a -> a
unsafePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$ do
Int
v <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
mv
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
vInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall a. HasCallStack => String -> a
error String
"UName: root name supply used after saving"
IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
mv (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
v