Reduce code duplication in *Id types

Closes #137

dejafu-tests/Cases/Properties.hs

@@ -26,11 +26,8 @@ import Common
 tests :: [Test]
 tests =
   [ testGroup "Class Laws"
-    [ testGroup "ThreadId" (eqord (Proxy :: Proxy D.ThreadId))
-    , testGroup "CRefId"   (eqord (Proxy :: Proxy D.CRefId))
-    , testGroup "MVarId"   (eqord (Proxy :: Proxy D.MVarId))
-    , testGroup "TVarId"   (eqord (Proxy :: Proxy D.TVarId))
-    , testGroup "Failure"  (eqord (Proxy :: Proxy D.Failure))
+    [ testGroup "Id"      (eqord (Proxy :: Proxy D.Id))
+    , testGroup "Failure" (eqord (Proxy :: Proxy D.Failure))
     ]
 
   , testGroup "Common"
@@ -163,16 +160,19 @@ eq_wb (Mem.WriteBuffer wb1) (Mem.WriteBuffer wb2) = andM (pure (ks1 == ks2) :
 -- Typeclass instances
 
 instance Listable D.ThreadId where
-  tiers = mapT (D.ThreadId Nothing) tiers
+  tiers = mapT D.ThreadId tiers
 
 instance Listable D.CRefId where
-  tiers = mapT (D.CRefId Nothing) tiers
+  tiers = mapT D.CRefId tiers
 
 instance Listable D.MVarId where
-  tiers = mapT (D.MVarId Nothing) tiers
+  tiers = mapT D.MVarId tiers
 
 instance Listable D.TVarId where
-  tiers = mapT (D.TVarId Nothing) tiers
+  tiers = mapT D.TVarId tiers
+
+instance Listable D.Id where
+  tiers = mapT (D.Id Nothing) tiers
 
 instance Listable D.ThreadAction where
   tiers =

dejafu/CHANGELOG.markdown

@@ -61,6 +61,9 @@ This project is versioned according to the [Package Versioning Policy](https://p
 
 - The `Discard` type is now defined here and re-exported from Test.DejaFu.SCT.
 
+- The `ThreadId`, `CRefId`, `MVarId`, and `TVarId` types are now newtypes over a common `Id`
+  type. (#137)
+
 ### Test.DejaFu.Conc
 
 - The `ConcST` type alias is gone.

dejafu/Test/DejaFu/Conc/Internal/Memory.hs

@@ -129,7 +129,7 @@ writeBarrier (WriteBuffer wb) = mapM_ flush $ M.elems wb where
 -- | Add phantom threads to the thread list to commit pending writes.
 addCommitThreads :: WriteBuffer r -> Threads n r -> Threads n r
 addCommitThreads (WriteBuffer wb) ts = ts <> M.fromList phantoms where
-  phantoms = [ (ThreadId Nothing $ negate tid, mkthread c)
+  phantoms = [ (ThreadId (Id Nothing $ negate tid), mkthread c)
              | ((_, b), tid) <- zip (M.toList wb) [1..]
              , c <- maybeToList (go $ viewl b)
              ]

dejafu/Test/DejaFu/Internal.hs

@@ -25,63 +25,47 @@ import           Test.DejaFu.Types
 
 -- | The number of ID parameters was getting a bit unwieldy, so this
 -- hides them all away.
-data IdSource = Id
-  { _nextCRId  :: Int
-  , _nextMVId  :: Int
-  , _nextTVId  :: Int
-  , _nextTId   :: Int
-  , _usedCRNames :: [String]
-  , _usedMVNames :: [String]
-  , _usedTVNames :: [String]
-  , _usedTNames  :: [String]
+data IdSource = IdSource
+  { _crids :: (Int, [String])
+  , _mvids :: (Int, [String])
+  , _tvids :: (Int, [String])
+  , _tids  :: (Int, [String])
   } deriving (Eq, Ord, Show)
 
 instance NFData IdSource where
-  rnf idsource = rnf ( _nextCRId idsource
-                     , _nextMVId idsource
-                     , _nextTVId idsource
-                     , _nextTId  idsource
-                     , _usedCRNames idsource
-                     , _usedMVNames idsource
-                     , _usedTVNames idsource
-                     , _usedTNames  idsource
+  rnf idsource = rnf ( _crids idsource
+                     , _mvids idsource
+                     , _tvids idsource
+                     , _tids  idsource
                      )
 
 -- | Get the next free 'CRefId'.
 nextCRId :: String -> IdSource -> (IdSource, CRefId)
-nextCRId name idsource = (newIdSource, newCRId) where
-  newIdSource = idsource { _nextCRId = newId, _usedCRNames = newUsed }
-  newCRId     = CRefId newName newId
-  newId       = _nextCRId idsource + 1
-  (newName, newUsed) = nextId name (_usedCRNames idsource)
+nextCRId name idsource =
+  let (crid, crids') = nextId name (_crids idsource)
+  in (idsource { _crids = crids' }, CRefId crid)
 
 -- | Get the next free 'MVarId'.
 nextMVId :: String -> IdSource -> (IdSource, MVarId)
-nextMVId name idsource = (newIdSource, newMVId) where
-  newIdSource = idsource { _nextMVId = newId, _usedMVNames = newUsed }
-  newMVId     = MVarId newName newId
-  newId       = _nextMVId idsource + 1
-  (newName, newUsed) = nextId name (_usedMVNames idsource)
+nextMVId name idsource =
+  let (mvid, mvids') = nextId name (_mvids idsource)
+  in (idsource { _mvids = mvids' }, MVarId mvid)
 
 -- | Get the next free 'TVarId'.
 nextTVId :: String -> IdSource -> (IdSource, TVarId)
-nextTVId name idsource = (newIdSource, newTVId) where
-  newIdSource = idsource { _nextTVId = newId, _usedTVNames = newUsed }
-  newTVId     = TVarId newName newId
-  newId       = _nextTVId idsource + 1
-  (newName, newUsed) = nextId name (_usedTVNames idsource)
+nextTVId name idsource =
+  let (tvid, tvids') = nextId name (_tvids idsource)
+  in (idsource { _tvids = tvids' }, TVarId tvid)
 
 -- | Get the next free 'ThreadId'.
 nextTId :: String -> IdSource -> (IdSource, ThreadId)
-nextTId name idsource = (newIdSource, newTId) where
-  newIdSource = idsource { _nextTId = newId, _usedTNames = newUsed }
-  newTId      = ThreadId newName newId
-  newId       = _nextTId idsource + 1
-  (newName, newUsed) = nextId name (_usedTNames idsource)
+nextTId name idsource =
+  let (tid, tids') = nextId name (_tids idsource)
+  in (idsource { _tids = tids' }, ThreadId tid)
 
 -- | Helper for @next*@
-nextId :: String -> [String] -> (Maybe String, [String])
-nextId name used = (newName, newUsed) where
+nextId :: String -> (Int, [String]) -> (Id, (Int, [String]))
+nextId name (num, used) = (Id newName (num+1), (num+1, newUsed)) where
   newName
     | null name = Nothing
     | occurrences > 0 = Just (name ++ "-" ++ show occurrences)
@@ -93,7 +77,7 @@ nextId name used = (newName, newUsed) where
 
 -- | The initial ID source.
 initialIdSource :: IdSource
-initialIdSource = Id 0 0 0 0 [] [] [] []
+initialIdSource = IdSource (0, []) (0, []) (0, []) (0, [])
 
 -------------------------------------------------------------------------------
 -- * Actions

dejafu/Test/DejaFu/Types.hs

@@ -1,10 +1,12 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 -- |
 -- Module      : Test.DejaFu.Types
 -- Copyright   : (c) 2017 Michael Walker
 -- License     : MIT
 -- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
 -- Stability   : experimental
--- Portability : portable
+-- Portability : GeneralizedNewtypeDeriving
 --
 -- Common types and functions used throughout DejaFu.
 module Test.DejaFu.Types where
@@ -19,105 +21,64 @@ import           Data.Function     (on)
 
 -- | Every live thread has a unique identitifer.
 --
--- The @Eq@ and @Ord@ instances only consider the int, not the name.
---
--- @since 0.4.0.0
-data ThreadId = ThreadId (Maybe String) {-# UNPACK #-} !Int
-
--- | Previously this was a derived instance.
---
--- @since 0.7.2.0
-instance Eq ThreadId where
-  (ThreadId _ i) == (ThreadId _ j) = i == j
-
-instance Ord ThreadId where
-  compare (ThreadId _ i) (ThreadId _ j) = compare i j
+-- @since 1.0.0.0
+newtype ThreadId = ThreadId Id
+  deriving (Eq, Ord, NFData)
 
 instance Show ThreadId where
-  show (ThreadId (Just n) _) = n
-  show (ThreadId Nothing  i) = show i
-
--- | @since 0.5.1.0
-instance NFData ThreadId where
-  rnf (ThreadId n i) = rnf (n, i)
+  show (ThreadId id_) = show id_
 
 -- | Every @CRef@ has a unique identifier.
 --
--- The @Eq@ and @Ord@ instances only consider the int, not the name.
---
--- @since 0.4.0.0
-data CRefId = CRefId (Maybe String) {-# UNPACK #-} !Int
-
--- | Previously this was a derived instance.
---
--- @since 0.7.2.0
-instance Eq CRefId where
-  (CRefId _ i) == (CRefId _ j) = i == j
-
-instance Ord CRefId where
-  compare (CRefId _ i) (CRefId _ j) = compare i j
+-- @since 1.0.0.0
+newtype CRefId = CRefId Id
+  deriving (Eq, Ord, NFData)
 
 instance Show CRefId where
-  show (CRefId (Just n) _) = n
-  show (CRefId Nothing  i) = show i
-
--- | @since 0.5.1.0
-instance NFData CRefId where
-  rnf (CRefId n i) = rnf (n, i)
+  show (CRefId id_) = show id_
 
 -- | Every @MVar@ has a unique identifier.
 --
--- The @Eq@ and @Ord@ instances only consider the int, not the name.
---
--- @since 0.4.0.0
-data MVarId = MVarId (Maybe String) {-# UNPACK #-} !Int
-
--- | Previously this was a derived instance.
---
--- @since 0.7.2.0
-instance Eq MVarId where
-  (MVarId _ i) == (MVarId _ j) = i == j
-
-instance Ord MVarId where
-  compare (MVarId _ i) (MVarId _ j) = compare i j
+-- @since 1.0.0.0
+newtype MVarId = MVarId Id
+  deriving (Eq, Ord, NFData)
 
 instance Show MVarId where
-  show (MVarId (Just n) _) = n
-  show (MVarId Nothing  i) = show i
-
--- | @since 0.5.1.0
-instance NFData MVarId where
-  rnf (MVarId n i) = rnf (n, i)
+  show (MVarId id_) = show id_
 
 -- | Every @TVar@ has a unique identifier.
 --
--- The @Eq@ and @Ord@ instances only consider the int, not the name.
---
--- @since 0.4.0.0
-data TVarId = TVarId (Maybe String) {-# UNPACK #-} !Int
-
--- | Previously this was a derived instance.
---
--- @since 0.7.2.0
-instance Eq TVarId where
-  (TVarId _ i) == (TVarId _ j) = i == j
-
-instance Ord TVarId where
-  compare (TVarId _ i) (TVarId _ j) = compare i j
+-- @since 1.0.0.0
+newtype TVarId = TVarId Id
+  deriving (Eq, Ord, NFData)
 
 instance Show TVarId where
-  show (TVarId (Just n) _) = n
-  show (TVarId Nothing  i) = show i
+  show (TVarId id_) = show id_
 
--- | @since 0.5.1.0
-instance NFData TVarId where
-  rnf (TVarId n i) = rnf (n, i)
+-- | An identifier for a thread, @MVar@, @CRef@, or @TVar@.
+--
+-- The number is the important bit.  The string is to make execution
+-- traces easier to read, but is meaningless.
+data Id = Id (Maybe String) {-# UNPACK #-} !Int
+
+instance Eq Id where
+  (Id _ i) == (Id _ j) = i == j
+
+instance Ord Id where
+  compare (Id _ i) (Id _ j) = compare i j
+
+instance Show Id where
+  show (Id (Just n) _) = n
+  show (Id _ i) = show i
+
+instance NFData Id where
+  rnf (Id n i) = rnf (n, i)
 
 -- | The ID of the initial thread.
 --
 -- @since 0.4.0.0
 initialThread :: ThreadId
-initialThread = ThreadId (Just "main") 0
+initialThread = ThreadId (Id (Just "main") 0)
 
 -------------------------------------------------------------------------------
 -- * Actions

dejafu/Test/DejaFu/Utils.hs

@@ -25,8 +25,8 @@ showTrace :: Trace -> String
 showTrace []  = "<trace discarded>"
 showTrace trc = intercalate "\n" $ go False trc : strkey where
   go _ ((_,_,CommitCRef _ _):rest) = "C-" ++ go False rest
-  go _ ((Start    (ThreadId _ i),_,a):rest) = "S" ++ show i ++ "-" ++ go (didYield a) rest
-  go y ((SwitchTo (ThreadId _ i),_,a):rest) = (if y then "p" else "P") ++ show i ++ "-" ++ go (didYield a) rest
+  go _ ((Start    (ThreadId (Id _ i)),_,a):rest) = "S" ++ show i ++ "-" ++ go (didYield a) rest
+  go y ((SwitchTo (ThreadId (Id _ i)),_,a):rest) = (if y then "p" else "P") ++ show i ++ "-" ++ go (didYield a) rest
   go _ ((Continue,_,a):rest) = '-' : go (didYield a) rest
   go _ _ = ""
 
@@ -42,8 +42,8 @@ showTrace trc = intercalate "\n" $ go False trc : strkey where
 -- @since 0.7.3.0
 threadNames :: Trace -> [(Int, String)]
 threadNames = mapMaybe go where
-  go (_, _, Fork   (ThreadId (Just name) i)) = Just (i, name)
-  go (_, _, ForkOS (ThreadId (Just name) i)) = Just (i, name)
+  go (_, _, Fork   (ThreadId (Id (Just name) i))) = Just (i, name)
+  go (_, _, ForkOS (ThreadId (Id (Just name) i))) = Just (i, name)
   go _ = Nothing
 
 -- | Pretty-print a failure