diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md index 6d0a6be4..1a45b351 100644 --- a/io-classes/CHANGELOG.md +++ b/io-classes/CHANGELOG.md @@ -1,5 +1,10 @@ # Revsion history of io-classes +### next release + +* 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 * Added support for `ghc-9.2`. diff --git a/io-classes/io-classes.cabal b/io-classes/io-classes.cabal index 14516eab..1038dbd0 100644 --- a/io-classes/io-classes.cabal +++ b/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, diff --git a/io-classes/mtl/Control/Monad/Class/MonadUnique/Trans.hs b/io-classes/mtl/Control/Monad/Class/MonadUnique/Trans.hs new file mode 100644 index 00000000..4c29dccb --- /dev/null +++ b/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 diff --git a/io-classes/src/Control/Monad/Class/MonadUnique.hs b/io-classes/src/Control/Monad/Class/MonadUnique.hs new file mode 100644 index 00000000..c00bba35 --- /dev/null +++ b/io-classes/src/Control/Monad/Class/MonadUnique.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +-- | A generalisation of the +-- +-- API to both 'IO' and . +-- +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 diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index 34c6b6c8..40fda8d4 100644 --- a/io-sim/CHANGELOG.md +++ b/io-sim/CHANGELOG.md @@ -6,6 +6,8 @@ ### Non-breaking changes +* Added support for unique symbol generation à la `Data.Unique`. + ### 1.8.0.1 * Added support for `ghc-9.2`. diff --git a/io-sim/src/Control/Monad/IOSim.hs b/io-sim/src/Control/Monad/IOSim.hs index ee6e8e66..ecd0f1be 100644 --- a/io-sim/src/Control/Monad/IOSim.hs +++ b/io-sim/src/Control/Monad/IOSim.hs @@ -48,6 +48,7 @@ module Control.Monad.IOSim , ThreadLabel , IOSimThreadId (..) , Labelled (..) + , Unique -- ** Dynamic Tracing , traceM , traceSTM diff --git a/io-sim/src/Control/Monad/IOSim/CommonTypes.hs b/io-sim/src/Control/Monad/IOSim/CommonTypes.hs index 2d1758aa..31dd4bf3 100644 --- a/io-sim/src/Control/Monad/IOSim/CommonTypes.hs +++ b/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 -- diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index 7037e0aa..c9e3fc3c 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/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 = diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs index c1a7e447..e20a0087 100644 --- a/io-sim/src/Control/Monad/IOSim/Types.hs +++ b/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, " ", diff --git a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs index 92a7b3e7..5e80764a 100644 --- a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs +++ b/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 =