Merge pull request #223 from LSLeary/unique-symbol-generation

Unique Symbol Generation

Author: coot

io-classes/CHANGELOG.md

@@ -1,14 +1,16 @@
 # Revsion history of io-classes
 
-### next version
+## next release
 
 ### Breaking changes
 
 ### Non-breaking changes
 
 * Improved performance of `tryReadTBQueueDefault`.
+* Added module `Control.Monad.Class.MonadUnique` generalising `Data.Unique`.
+* mtl: Added module `Control.Monad.Class.MonadUnique.Trans` providing monad transformer instances for `MonadUnique`.
 
-### 1.8.0.1
+## 1.8.0.1
 
 * Added support for `ghc-9.2`.
 
@@ -33,13 +35,13 @@
   type classes.
 * Support ghc-9.12
 
-### 1.7.0.0
+## 1.7.0.0
 
 ### Breaking changes
 
 * Renamed `io-classes:io-classes-mtl` as `io-classes:mtl`.
 
-### 1.6.0.0
+## 1.6.0.0
 
 ### Breaking changes
 

io-classes/io-classes.cabal

@@ -87,6 +87,7 @@ library
                        Control.Monad.Class.MonadTime
                        Control.Monad.Class.MonadTimer
                        Control.Monad.Class.MonadTest
+                       Control.Monad.Class.MonadUnique
   default-language:    GHC2021
   default-extensions:  LambdaCase
   build-depends:       base  >=4.16 && <4.22,
@@ -174,6 +175,7 @@ library mtl
                    ,  Control.Monad.Class.MonadTime.SI.Trans
                    ,  Control.Monad.Class.MonadTimer.Trans
                    ,  Control.Monad.Class.MonadTimer.SI.Trans
+                   ,  Control.Monad.Class.MonadUnique.Trans
     build-depends:    base,
                       array,
                       mtl,

io-classes/mtl/Control/Monad/Class/MonadUnique/Trans.hs

@@ -0,0 +1,40 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Control.Monad.Class.MonadUnique.Trans () where
+
+import Control.Monad.Cont (ContT)
+import Control.Monad.Except (ExceptT)
+import Control.Monad.RWS.Lazy qualified as Lazy
+import Control.Monad.RWS.Strict qualified as Strict
+import Control.Monad.State.Lazy qualified as Lazy
+import Control.Monad.State.Strict qualified as Strict
+import Control.Monad.Writer.Lazy qualified as Lazy
+import Control.Monad.Writer.Strict qualified as Strict
+
+import Control.Monad.Class.MonadUnique
+
+
+instance MonadUnique m => MonadUnique (ContT r m) where
+  type Unique (ContT r m) = UniqueFor (ContT r) m
+
+instance MonadUnique m => MonadUnique (ExceptT e m) where
+  type Unique (ExceptT e m) = UniqueFor (ExceptT e) m
+
+instance (MonadUnique m, Monoid w) => MonadUnique (Lazy.RWST r w s m) where
+  type Unique (Lazy.RWST r w s m) = UniqueFor (Lazy.RWST r w s) m
+
+instance (MonadUnique m, Monoid w) => MonadUnique (Strict.RWST r w s m) where
+  type Unique (Strict.RWST r w s m) = UniqueFor (Strict.RWST r w s) m
+
+instance MonadUnique m => MonadUnique (Lazy.StateT s m) where
+  type Unique (Lazy.StateT s m) = UniqueFor (Lazy.StateT s) m
+
+instance MonadUnique m => MonadUnique (Strict.StateT s m) where
+  type Unique (Strict.StateT s m) = UniqueFor (Strict.StateT s) m
+
+instance (MonadUnique m, Monoid w) => MonadUnique (Lazy.WriterT w m) where
+  type Unique (Lazy.WriterT w m) = UniqueFor (Lazy.WriterT w) m
+
+instance (MonadUnique m, Monoid w) => MonadUnique (Strict.WriterT w m) where
+  type Unique (Strict.WriterT w m) = UniqueFor (Strict.WriterT w) m

io-classes/src/Control/Monad/Class/MonadUnique.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE DefaultSignatures      #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+
+-- | A generalisation of the
+-- <https://hackage.haskell.org/package/base/docs/Data-Unique.html Data.Unique>
+-- API to both 'IO' and <https://hackage.haskell.org/package/io-sim IOSim>.
+--
+module Control.Monad.Class.MonadUnique
+  ( MonadUnique (..)
+  , UniqueFor (..)
+  ) where
+
+-- base
+import Data.Kind (Type)
+import Data.Unique qualified as IO
+
+-- transformers
+import Control.Monad.Reader (MonadTrans (..), ReaderT (..), lift)
+
+
+class (Monad m, Eq (Unique m), Ord (Unique m)) => MonadUnique m where
+  type Unique m = (unique :: Type) | unique -> m
+  newUnique  :: m (Unique m)
+  hashUnique :: Unique m -> Int
+
+  default
+    newUnique
+      :: (m ~ t n, Unique m ~ UniqueFor t n, MonadTrans t, MonadUnique n)
+      => m (Unique m)
+  default
+    hashUnique
+      :: (m ~ t n, Unique m ~ UniqueFor t n, MonadUnique n)
+      => Unique m -> Int
+  newUnique  = lift (MkUniqueFor <$> newUnique)
+  hashUnique = hashUnique . unMkUniqueFor
+
+instance MonadUnique IO where
+  type Unique IO = IO.Unique
+  newUnique  = IO.newUnique
+  hashUnique = IO.hashUnique
+
+
+newtype UniqueFor t m = MkUniqueFor{ unMkUniqueFor :: Unique m }
+deriving instance MonadUnique m => Eq  (UniqueFor r m)
+deriving instance MonadUnique m => Ord (UniqueFor r m)
+
+instance MonadUnique m => MonadUnique (ReaderT r m) where
+  type Unique (ReaderT r m) = UniqueFor (ReaderT r) m

io-sim/CHANGELOG.md

@@ -6,9 +6,10 @@
 
 ### Non-breaking changes
 
+* Added support for unique symbol generation à la `Data.Unique`.
 * Removed a misleading internal comment.
 
-### 1.8.0.1
+## 1.8.0.1
 
 * Added support for `ghc-9.2`.
 

io-sim/src/Control/Monad/IOSim.hs

@@ -48,6 +48,7 @@ module Control.Monad.IOSim
   , ThreadLabel
   , IOSimThreadId (..)
   , Labelled (..)
+  , Unique
     -- ** Dynamic Tracing
   , traceM
   , traceSTM

io-sim/src/Control/Monad/IOSim/CommonTypes.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveAnyClass     #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DerivingVia        #-}
+{-# LANGUAGE RoleAnnotations    #-}
 
 -- | Common types shared between `IOSim` and `IOSimPOR`.
 --
@@ -28,6 +29,7 @@ module Control.Monad.IOSim.CommonTypes
   , BlockedReason (..)
   , Labelled (..)
   , ppLabelled
+  , Unique (..)
     -- * Utils
   , ppList
   ) where
@@ -202,6 +204,16 @@ ppLabelled :: (a -> String) -> Labelled a -> String
 ppLabelled pp Labelled { l_labelled = a, l_label = Nothing  } = pp a
 ppLabelled pp Labelled { l_labelled = a, l_label = Just lbl } = concat ["Labelled ", pp a, " ", lbl]
 
+-- | Abstract unique symbols à la "Data.Unique".
+newtype Unique s = MkUnique{ unMkUnique :: Integer }
+  deriving stock   (Eq, Ord)
+  deriving newtype NFData
+type role Unique nominal
+
+instance Hashable (Unique s) where
+  hash = fromInteger . unMkUnique
+  hashWithSalt = defaultHashWithSalt
+
 --
 -- Utils
 --

io-sim/src/Control/Monad/IOSim/Internal.hs

@@ -143,7 +143,8 @@ data SimState s a = SimState {
        -- | list of clocks
        clocks   :: !(Map ClockId UTCTime),
        nextVid  :: !VarId,     -- ^ next unused 'VarId'
-       nextTmid :: !TimeoutId   -- ^ next unused 'TimeoutId'
+       nextTmid :: !TimeoutId, -- ^ next unused 'TimeoutId'
+       nextUniq :: !(Unique s) -- ^ next unused @'Unique' s@
      }
 
 initialState :: SimState s a
@@ -155,7 +156,8 @@ initialState =
       timers   = PSQ.empty,
       clocks   = Map.singleton (ClockId []) epoch1970,
       nextVid  = 0,
-      nextTmid = TimeoutId 0
+      nextTmid = TimeoutId 0,
+      nextUniq = MkUnique 0
     }
   where
     epoch1970 = UTCTime (fromGregorian 1970 1 1) 0
@@ -197,7 +199,7 @@ schedule !thread@Thread{
            threads,
            timers,
            clocks,
-           nextVid, nextTmid,
+           nextVid, nextTmid, nextUniq,
            curTime  = time
          } =
   invariant (Just thread) simstate $
@@ -631,6 +633,13 @@ schedule !thread@Thread{
           thread' = thread { threadControl = ThreadControl k' ctl }
       schedule thread' simstate
 
+    NewUnique k -> do
+      let thread'   = thread{ threadControl = ThreadControl (k nextUniq) ctl }
+          n         = unMkUnique nextUniq
+          simstate' = simstate{ nextUniq = MkUnique (n + 1) }
+      SimTrace time tid tlbl (EventUniqueCreated n)
+        <$> schedule thread' simstate'
+
 
 threadInterruptible :: Thread s a -> Bool
 threadInterruptible thread =

io-sim/src/Control/Monad/IOSim/Types.hs

@@ -93,6 +93,7 @@ import Control.Monad.Class.MonadTime.SI qualified as SI
 import Control.Monad.Class.MonadTimer
 import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))
 import Control.Monad.Class.MonadTimer.SI qualified as SI
+import Control.Monad.Class.MonadUnique
 import Control.Monad.Primitive qualified as Prim
 import Control.Monad.ST.Lazy
 import Control.Monad.ST.Strict qualified as StrictST
@@ -104,6 +105,7 @@ import Control.Monad.Fail qualified as Fail
 import Data.Bifoldable
 import Data.Bifunctor (bimap)
 import Data.Dynamic (Dynamic, toDyn)
+import Data.Hashable (Hashable (hash))
 import Data.List.Trace qualified as Trace
 import Data.Map.Strict (Map)
 import Data.Maybe (fromMaybe)
@@ -122,6 +124,7 @@ import GHC.Generics (Generic)
 import Quiet (Quiet (..))
 
 import Control.Monad.IOSim.CommonTypes
+import Control.Monad.IOSim.CommonTypes qualified as Sim
 import Control.Monad.IOSim.STM
 import Control.Monad.IOSimPOR.Types
 
@@ -193,6 +196,7 @@ data SimA s a where
   ExploreRaces :: SimA s b -> SimA s b
 
   Fix          :: (x -> IOSim s x) -> (x -> SimA s r) -> SimA s r
+  NewUnique    :: (Sim.Unique s -> SimA s r) -> SimA s r
 
 
 newtype STM s a = STM { unSTM :: forall r. (a -> StmA s r) -> StmA s r }
@@ -626,6 +630,11 @@ instance MonadTraceMVar (IOSim s) where
 instance MonadLabelledMVar (IOSim s) where
   labelMVar = labelMVarDefault
 
+instance MonadUnique (IOSim s) where
+  type Unique (IOSim s) = Sim.Unique s
+  newUnique  = IOSim (oneShot NewUnique)
+  hashUnique = hash
+
 data Async s a = Async !IOSimThreadId (STM s (Either SomeException a))
 
 instance Eq (Async s a) where
@@ -1056,6 +1065,9 @@ data SimEventType
   | EventThreadUnhandled SomeException
   -- ^ thread terminated by an unhandled exception
 
+  | EventUniqueCreated Integer
+  -- ^ created the n-th 'Unique'
+
   --
   -- STM events
   --
@@ -1163,6 +1175,7 @@ ppSimEventType = \case
   EventThreadFinished -> "ThreadFinished"
   EventThreadUnhandled a ->
     "ThreadUnhandled " ++ show a
+  EventUniqueCreated n -> "UniqueCreated " ++ show n
   EventTxCommitted written created mbEff ->
     concat [ "TxCommitted ",
              ppList (ppLabelled show) written, " ",

io-sim/src/Control/Monad/IOSimPOR/Internal.hs

@@ -200,6 +200,7 @@ data SimState s a = SimState {
        nextTmid         :: !TimeoutId,  -- ^ next unused 'TimeoutId'
        -- | previous steps (which we may race with).
        -- Note this is *lazy*, so that we don't compute races we will not reverse.
+       nextUniq         :: !(Unique s), -- ^ next unused @'Unique' s@
        races            :: Races,
        -- | control the schedule followed, and initial value
        control          :: !ScheduleControl,
@@ -220,6 +221,7 @@ initialState =
       clocks   = Map.singleton (ClockId []) epoch1970,
       nextVid  = 0,
       nextTmid = TimeoutId 0,
+      nextUniq = MkUnique 0,
       races    = noRaces,
       control  = ControlDefault,
       control0 = ControlDefault,
@@ -273,7 +275,7 @@ schedule thread@Thread{
            threads,
            timers,
            clocks,
-           nextVid, nextTmid,
+           nextVid, nextTmid, nextUniq,
            curTime  = time,
            control,
            perStepTimeLimit
@@ -814,6 +816,13 @@ schedule thread@Thread{
       let thread' = thread { threadControl = ThreadControl k ctl }
       schedule thread' simstate
 
+    NewUnique k -> do
+      let thread'   = thread{ threadControl = ThreadControl (k nextUniq) ctl }
+          n         = unMkUnique nextUniq
+          simstate' = simstate{ nextUniq = MkUnique (n + 1) }
+      SimPORTrace time tid tstep tlbl (EventUniqueCreated n)
+        <$> schedule thread' simstate'
+
 
 threadInterruptible :: Thread s a -> Bool
 threadInterruptible thread =