Ticket #9918: Minimal.hs

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

Miminized 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 System.IO
9import Control.Applicative
10import Control.Monad.Reader
11import Control.Monad.Trans
12import Data.IORef
13
14newtype IORT s m v = IORT{ unIORT:: ReaderT (IORef [HandleR]) m v } 
15    deriving (Functor, Applicative, Monad)
16
17newtype SHandle (m :: * -> *) = SHandle Handle  -- data ctor not exported
18
19newtype HandleR = HandleR Handle
20
21class (Monad m1, Monad m2) => MonadRaise m1 m2 where
22  lifts :: m1 a -> m2 a
23
24-- closed type families based solution (doesn't work)
25------------------------------------------------------
26type family TEQ (a :: * -> *) (b :: * -> *) :: Bool where
27  TEQ m  m  = True
28  TEQ m1 (IORT s m2) = False
29
30data Proxy (b::Bool) = Proxy
31
32class (Monad m1, Monad m2) => MonadRaise' (b::Bool) m1 m2 where
33  lifts' :: Proxy b -> m1 a -> m2 a
34
35instance (MonadRaise' (TEQ m1 m2) m1 m2) => MonadRaise m1 m2 where
36  lifts = lifts' (Proxy::Proxy (TEQ m1 m2))
37
38instance (Monad m1, Monad m2, m1 ~ m2) => MonadRaise' True m1 m2 where
39  lifts' _ = id
40
41instance (Monad m2, m2 ~ (IORT s m2'), MonadRaise m1 m2')
42    => MonadRaise' False m1 m2 where
43    lifts' _ = IORT . lift . lifts
44
45{-
46-- overlapping instances based solutio  (works)
47-----------------------------------------------
48instance Monad m => MonadRaise m m where
49    lifts = id
50
51instance (Monad m2, m2 ~ (IORT s m2'), MonadRaise m1 m2')
52    => MonadRaise m1 m2 where
53    lifts = IORT . lift . lifts
54-}
55
56-- Test that doesn't work
57--------------------------------------------------------------------
58test_copy _ fname_out = do
59  hout <- newSHandle fname_out WriteMode
60  (do newRgn (do
61        till (return True)
62             (return "foo" >>= shPutStrLn hout)))
63-------------------------------------------------------------------
64
65-- other functions that are used
66newSHandle :: (m ~ (IORT s' m'), SMonad1IO m) => 
67              FilePath -> IOMode -> m (SHandle m)
68newSHandle = undefined
69
70newRgn :: RMonadIO m => (forall s. IORT s m v) -> m v
71newRgn = undefined
72
73till :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m ()
74till condition iteration = loop where
75  loop = do b <- condition
76            if b then return () else iteration >> loop
77
78shPutStrLn :: (MonadRaise m1 m2, SMonadIO m2) => SHandle m1 -> String -> m2 ()
79shPutStrLn = undefined
80
81-- RMonad:
82class Monad m => RMonadIO m where lIO   :: IO a -> m a
83
84instance RMonadIO IO where lIO   = id
85instance RMonadIO m => RMonadIO (ReaderT r m) where lIO = lift . lIO
86instance RMonadIO m => RMonadIO (IORT s m) where lIO = IORT . lIO
87
88-- SMonadIO
89class RMonadIO m => SMonadIO m
90instance RMonadIO m => SMonadIO (IORT s m)
91
92-- SMonad1IO
93class RMonadIO (UnIORT m) => SMonad1IO m
94instance RMonadIO m => SMonad1IO (IORT s m)
95
96type family UnIORT (m :: * -> *) :: * -> *
97type instance UnIORT (IORT s m) = m