Ticket #9918: Minimal.2.hs

File Minimal.2.hs, 2.0 KB (added by qnikst, 5 years ago)

Better minimized example

Line 
1{-# LANGUAGE Rank2Types, GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE DataKinds, KindSignatures, MultiParamTypeClasses
3             , TypeFamilies, FlexibleInstances, UndecidableInstances #-}
4{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
5
6{-# LANGUAGE OverlappingInstances #-}
7
8import Control.Applicative
9import Control.Monad.Reader
10
11newtype IORT s m v = IORT{ unIORT:: ReaderT () m v } 
12    deriving (Functor, Applicative, Monad, MonadIO)
13
14newtype SHandle (m :: * -> *) = SHandle ()
15
16class (Monad m1, Monad m2) => MonadRaise m1 m2 where
17  lifts :: m1 a -> m2 a
18
19-- closed type families based solution (doesn't work)
20------------------------------------------------------
21
22type family TEQ (a :: * -> *) (b :: * -> *) :: Bool where
23  TEQ m  m  = True
24  TEQ m1 (IORT s m2) = False
25
26data Proxy (b::Bool) = Proxy
27
28class (Monad m1, Monad m2) => MonadRaise' (b::Bool) m1 m2 where
29  lifts' :: Proxy b -> m1 a -> m2 a
30
31instance (MonadRaise' (TEQ m1 m2) m1 m2) => MonadRaise m1 m2 where
32  lifts = lifts' (Proxy::Proxy (TEQ m1 m2))
33
34instance (Monad m1, Monad m2, m1 ~ m2) => MonadRaise' True m1 m2 where
35  lifts' _ = id
36
37instance (Monad m2, m2 ~ (IORT s m2'), MonadRaise m1 m2')
38  => MonadRaise' False m1 m2 where
39  lifts' _ = IORT . lift . lifts
40
41-- overlapping instances based solutio  (works)
42-----------------------------------------------
43
44{-
45instance Monad m => MonadRaise m m
46  where lifts = id
47
48instance (Monad m2, m2 ~ (IORT s m2'), MonadRaise m1 m2')
49  => MonadRaise m1 m2 where
50    lifts = IORT . lift . lifts
51-}
52
53-- Test that doesn't work
54--------------------------------------------------------------------
55test_copy :: forall s' (m' :: * -> *). MonadIO m' => IORT s' m' ()
56test_copy = do
57  hout <- newSHandle
58  newRgn $ shPutStrLn hout
59
60-------------------------------------------------------------------
61
62newSHandle :: (m ~ (IORT s' m'), MonadIO m) => m (SHandle m)
63newSHandle = undefined
64
65newRgn :: MonadIO m => (forall s. IORT s m v) -> m v
66newRgn = undefined
67
68shPutStrLn :: (MonadRaise m1 m2, MonadIO m2) => SHandle m1 -> m2 ()
69shPutStrLn = undefined