{-# LANGUAGE BangPatterns, FlexibleInstances #-}
module Unsafe.Unique.Prim
    ( Uniq, getUniq
    , unsafeMkUniq, unsafeShowsPrecUniq, unsafeShowUniq
    ) where

import Control.Monad.Primitive
import Data.IORef
import System.IO.Unsafe

-- A smaller numeric type could be used, such as Word or Word64, but I
-- want to be able to guarantee uniqueness even over very long execution 
-- times.  Smaller types would require either checking for overflow,
-- accepting the possibility of aliasing, or tracking allocation and 
-- deallocation, which would be a lot of extra work.  Word64 is almost
-- certainly big enough for practical purposes, though.  Allocating one 
-- 'Uniq' every nanosecond, it would take 584 years to start aliasing....
-- So, in the future I may choose to switch to Word64.

-- |A 'Uniq' is a value that can only be constructed under controlled 
-- conditions (in IO or ST, basically), and once constructed can only be
-- compared to 'Uniq' values created under the same conditions (in the same
-- monad).  Upon comparison, a 'Uniq' is ONLY ever equal to itself.  Beyond
-- that, no promises regarding ordering are made except that once constructed
-- the order is deterministic and a proper ordering relation (eg, > is 
-- transitive and irreflexive, etc.)
newtype Uniq s = Uniq Integer deriving (Uniq s -> Uniq s -> Bool
(Uniq s -> Uniq s -> Bool)
-> (Uniq s -> Uniq s -> Bool) -> Eq (Uniq s)
forall s. Uniq s -> Uniq s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Uniq s -> Uniq s -> Bool
$c/= :: forall s. Uniq s -> Uniq s -> Bool
== :: Uniq s -> Uniq s -> Bool
$c== :: forall s. Uniq s -> Uniq s -> Bool
Eq, Eq (Uniq s)
Eq (Uniq s)
-> (Uniq s -> Uniq s -> Ordering)
-> (Uniq s -> Uniq s -> Bool)
-> (Uniq s -> Uniq s -> Bool)
-> (Uniq s -> Uniq s -> Bool)
-> (Uniq s -> Uniq s -> Bool)
-> (Uniq s -> Uniq s -> Uniq s)
-> (Uniq s -> Uniq s -> Uniq s)
-> Ord (Uniq s)
Uniq s -> Uniq s -> Bool
Uniq s -> Uniq s -> Ordering
Uniq s -> Uniq s -> Uniq s
forall s. Eq (Uniq s)
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
forall s. Uniq s -> Uniq s -> Bool
forall s. Uniq s -> Uniq s -> Ordering
forall s. Uniq s -> Uniq s -> Uniq s
min :: Uniq s -> Uniq s -> Uniq s
$cmin :: forall s. Uniq s -> Uniq s -> Uniq s
max :: Uniq s -> Uniq s -> Uniq s
$cmax :: forall s. Uniq s -> Uniq s -> Uniq s
>= :: Uniq s -> Uniq s -> Bool
$c>= :: forall s. Uniq s -> Uniq s -> Bool
> :: Uniq s -> Uniq s -> Bool
$c> :: forall s. Uniq s -> Uniq s -> Bool
<= :: Uniq s -> Uniq s -> Bool
$c<= :: forall s. Uniq s -> Uniq s -> Bool
< :: Uniq s -> Uniq s -> Bool
$c< :: forall s. Uniq s -> Uniq s -> Bool
compare :: Uniq s -> Uniq s -> Ordering
$ccompare :: forall s. Uniq s -> Uniq s -> Ordering
Ord)

-- |There is only one 'RealWorld', so this instance is sound (unlike the 
-- general 'unsafeShowsPrecUniq').  Note that there is no particular
-- relationship between 'Uniq' values (or the strings 'show' turns them into)
-- created in different executions of a program.  The value they render to
-- should be considered completely arbitrary, and the Show instance only even
-- exists for convenience when testing code that uses 'Uniq's.
instance Show (Uniq RealWorld) where
    showsPrec :: Int -> Uniq RealWorld -> ShowS
showsPrec = Int -> Uniq RealWorld -> ShowS
forall s. Int -> Uniq s -> ShowS
unsafeShowsPrecUniq

{-# NOINLINE nextUniq #-}
-- | [internal] Assuming the compiler behaves "as expected", this is a single
-- statically-created IORef holding the counter which will be used as the 
-- source of new 'Prim' keys (in 'ST' and 'IO').
nextUniq :: IORef Integer
nextUniq :: IORef Integer
nextUniq = IO (IORef Integer) -> IORef Integer
forall a. IO a -> a
unsafePerformIO (Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0)

-- |Construct a new 'Uniq' that is equal to itself, unequal to every other
-- 'Uniq' constructed in the same monad, and incomparable to every 'Uniq' 
-- constructed in any other monad.
getUniq :: PrimMonad m => m (Uniq (PrimState m))
getUniq :: forall (m :: * -> *). PrimMonad m => m (Uniq (PrimState m))
getUniq = IO (Uniq (PrimState m)) -> m (Uniq (PrimState m))
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim (IORef Integer
-> (Integer -> (Integer, Uniq (PrimState m)))
-> IO (Uniq (PrimState m))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Integer
nextUniq (\Integer
u -> (Integer
uInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1, Integer -> Uniq (PrimState m)
forall s. Integer -> Uniq s
Uniq Integer
u)))

-- |For the implementation of 'Uniq' construction in new monads, this operation
-- is exposed.  Users must accept responsibility for ensuring true uniqueness 
-- across the lifetime of the resulting 'Uniq' value.  Failure to do so could
-- lead to type unsoundness in code depending on uniqueness as a type witness
-- (eg, "Data.Unique.Tag").
unsafeMkUniq :: Integer -> Uniq s
unsafeMkUniq :: forall s. Integer -> Uniq s
unsafeMkUniq Integer
n = Integer -> Uniq s
forall s. Integer -> Uniq s
Uniq Integer
n

-- |A `Show` instance for @`Uniq` s@ would not be sound, but for debugging
-- purposes we occasionally will want to do it anyway.  Its unsoundness is 
-- nicely demonstrated by:
-- 
-- > runST (fmap show getUniq) :: String
--
-- Which, despite having type 'String', is not referentially transparent.
unsafeShowsPrecUniq :: Int -> Uniq s -> ShowS
unsafeShowsPrecUniq :: forall s. Int -> Uniq s -> ShowS
unsafeShowsPrecUniq Int
p (Uniq Integer
u) = Int -> Integer -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Integer
u

-- |See 'unsafeShowsPrecUniq'.
unsafeShowUniq :: Uniq s -> String
unsafeShowUniq :: forall s. Uniq s -> String
unsafeShowUniq (Uniq Integer
u) = Integer -> String
forall a. Show a => a -> String
show Integer
u