fixup! fixup! io-classes: Add MonadUnique to support Data.Unique

Author: LSLeary

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

@@ -1,56 +1,40 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE TypeFamilies, DerivingVia, UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Control.Monad.Class.MonadUnique.Trans () where
 
-import Data.Kind (Type)
-
 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.Trans (MonadTrans(..))
 import Control.Monad.Writer.Lazy qualified as Lazy
 import Control.Monad.Writer.Strict qualified as Strict
 
 import Control.Monad.Class.MonadUnique
 
 
-type Trans
-  :: ((Type -> Type) -> (Type -> Type))
-  ->  (Type -> Type) -> (Type -> Type)
-newtype Trans t m a = Trans (t m a)
-  deriving (Functor, Applicative, Monad, MonadTrans)
-
-instance (MonadTrans t, MonadUnique m) => MonadUnique (Trans t m) where
-  type Unique (Trans t m) = Unique m
-  newUnique  = lift newUnique
-  hashUnique = hashUnique @m
-
-
-deriving via Trans (ContT r) m
-  instance MonadUnique m => MonadUnique (ContT r m)
-
-deriving via Trans (ExceptT e) m
-  instance MonadUnique m => MonadUnique (ExceptT e m)
+instance MonadUnique m => MonadUnique (ContT r m) where
+  type Unique (ContT r m) = UniqueFor (ContT r) m
 
-deriving via Trans (Lazy.RWST r w s) m
-  instance (MonadUnique m, Monoid w) => MonadUnique (Lazy.RWST r w s m)
+instance MonadUnique m => MonadUnique (ExceptT e m) where
+  type Unique (ExceptT e m) = UniqueFor (ExceptT e) m
 
-deriving via Trans (Strict.RWST r w s) m
-  instance (MonadUnique m, Monoid w) => MonadUnique (Strict.RWST r w s 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
 
-deriving via Trans (Lazy.StateT s) m
-  instance MonadUnique m => MonadUnique (Lazy.StateT 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
 
-deriving via Trans (Strict.StateT s) m
-  instance MonadUnique m => MonadUnique (Strict.StateT s m)
+instance MonadUnique m => MonadUnique (Lazy.StateT s m) where
+  type Unique (Lazy.StateT s m) = UniqueFor (Lazy.StateT s) m
 
-deriving via Trans (Lazy.WriterT w) m
-  instance (MonadUnique m, Monoid w) => MonadUnique (Lazy.WriterT w m)
+instance MonadUnique m => MonadUnique (Strict.StateT s m) where
+  type Unique (Strict.StateT s m) = UniqueFor (Strict.StateT s) m
 
-deriving via Trans (Strict.WriterT w) m
-  instance (MonadUnique m, Monoid w) => MonadUnique (Strict.WriterT w 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

@@ -1,33 +1,48 @@
-{-# LANGUAGE TypeFamilies, AllowAmbiguousTypes #-}
+{-# 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(..)
+  MonadUnique (..),
+  UniqueFor (..),
 ) where
 
 -- base
 import Data.Kind (Type)
 import Data.Unique qualified as IO
 
 -- transformers
-import Control.Monad.Reader (ReaderT(..), lift)
+import Control.Monad.Reader (MonadTrans(..), ReaderT(..), lift)
 
 
 class (Monad m, Eq (Unique m), Ord (Unique m)) => MonadUnique m where
-  type Unique m :: Type
+  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
 
-instance MonadUnique m => MonadUnique (ReaderT r m) where
-  type Unique (ReaderT r m) = Unique m
-  newUnique  = lift newUnique
-  hashUnique = hashUnique @m
 
+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