Есть простенький код (Олеговские регионы, если кто не узнал), в нём хочется убрать перекрывающиеся инстансы для RMonad, что в принципе возможно при использовании закрытых семейств типов, например как описано ниже. Это почти работает, почти, т.к. в одном из тестов типы перестают выводиться (ошибка снизу поста). Вопрос, что с этим делать, ну не считая того, что доуменьшить пример, в очередной раз проконсультироваться с Олегом и послать баг репорт?
{-# LANGUAGE Rank2Types, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DataKinds, KindSignatures, MultiParamTypeClasses, TypeFamilies, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
import System.IO
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Trans
import Control.Exception
import Data.IORef
newtype IORT s m v = IORT{ unIORT:: ReaderT (IORef [HandleR]) m v }
deriving (Functor, Applicative, Monad)
newtype SHandle (m :: * -> *) = SHandle Handle -- data ctor not exported
newtype HandleR = HandleR Handle
class (Monad m1, Monad m2) => MonadRaise m1 m2 where
lifts :: m1 a -> m2 a
type family TEQ (a :: * -> *) (b :: * -> *) :: Bool where
TEQ m m = True
TEQ m1 (IORT s m2) = False
data Proxy (b::Bool) = Proxy
class (Monad m1, Monad m2) => MonadRaise' (b::Bool) m1 m2 where
lifts' :: Proxy b -> m1 a -> m2 a
instance (MonadRaise' (TEQ m1 m2) m1 m2) => MonadRaise m1 m2 where
lifts = lifts' (Proxy::Proxy (TEQ m1 m2))
instance (Monad m1, Monad m2, m1 ~ m2) => MonadRaise' True m1 m2 where
lifts' _ = id
instance (Monad m2, m2 ~ (IORT s m2'), MonadRaise m1 m2')
=> MonadRaise' False m1 m2 where
lifts' _ = IORT . lift . lifts
test_copy fname_in fname_out = do
hout <- newSHandle fname_out WriteMode
(do newRgn (do
till (return True)
(return "foo" >>= shPutStrLn hout)))
newSHandle :: (m ~ (IORT s' m'), SMonad1IO m) =>
FilePath -> IOMode -> m (SHandle m)
newSHandle = undefined
newRgn :: RMonadIO m => (forall s. IORT s m v) -> m v
newRgn = undefined
till :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m ()
till condition iteration = loop where
loop = do b <- condition
if b then return () else iteration >> loop
shPutStrLn :: (MonadRaise m1 m2, SMonadIO m2) => SHandle m1 -> String -> m2 ()
shPutStrLn = undefined
-- RMonad:
class Monad m => RMonadIO m where lIO :: IO a -> m a
instance RMonadIO IO where lIO = id
instance RMonadIO m => RMonadIO (ReaderT r m) where lIO = lift . lIO
instance RMonadIO m => RMonadIO (IORT s m) where lIO = IORT . lIO
-- SMonadIO
class RMonadIO m => SMonadIO m
instance RMonadIO m => SMonadIO (IORT s m)
-- SMonad1IO
class RMonadIO (UnIORT m) => SMonad1IO m
instance RMonadIO m => SMonad1IO (IORT s m)
type family UnIORT (m :: * -> *) :: * -> *
type instance UnIORT (IORT s m) = m
Ошибка:
Minimal.hs:45:32:
Could not deduce (MonadRaise'
(TEQ (IORT s' m') (IORT s (IORT s' m')))
(IORT s' m')
(IORT s (IORT s' m')))
arising from a use of ‘shPutStrLn’
from the context (RMonadIO m')
bound by the inferred type of
test_copy :: RMonadIO m' => t -> FilePath -> IORT s' m' ()
at Minimal.hs:(41,1)-(45,49)
In the second argument of ‘(>>=)’, namely ‘shPutStrLn hout’
In the second argument of ‘till’, namely
‘(return "foo" >>= shPutStrLn hout)’
In a stmt of a 'do' block:
till (return True) (return "foo" >>= shPutStrLn hout)
