LANGUAGE TypeFamilies FlexibleContexts import Control Monad Trans clas

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
import Control.Monad.Trans
class Throwable e where
type OuterException e
type OtherExceptions e
getOuterException :: e -> OuterException e
getOtherExceptions :: e -> OtherExceptions e
instance Throwable () where
type OuterException () = ()
type OtherExceptions () = ()
getOuterException () = ()
getOtherExceptions () = ()
instance (Throwable e1) => Throwable (e1, e2) where
type OuterException (e1, e2) = e2
type OtherExceptions (e1, e2) = e1
getOuterException (e1,e2) = e2
getOtherExceptions (e1,e2) = e1
data (Throwable e) => Result e a = Throw e | Result a
newtype (Monad m, Throwable e) => Throws e m a = Controller {
runController :: m (Result e a)
}
instance (Monad m, Throwable e) => Monad (Throws e m) where
return v = Controller $ return (Result v)
Controller cmd >>= f =
Controller $ do -- `do` in `m`
res <- cmd
case res of
Throw resp -> return (Throw resp)
Result res' -> (runController . f) res'
instance (Throwable e) => MonadTrans (Throws e) where
lift act = Controller $ do
res <- act
return (Result res)
throw :: (Monad m, Throwable e) => e -> Throws e m a
throw e = Controller $ return (Throw e)
exceptAll :: (Monad m, Throwable e) => Throws e m a -> (e -> m a) -> m a
exceptAll m f = do
res <- runController m
case res of
Throw e -> f e
Result r -> return r
except :: (Monad m, Throwable e, Throwable (OtherExceptions e)) => Throws e m a
-> (OuterException e -> Throws (OtherExceptions e) m a)
-> Throws (OtherExceptions e) m a
except m f = do
res <- lift $ runController m
case res of
Throw e -> f (getOuterException e)
Result a -> return a
try :: (Monad m) => Throws () m a -> m a
try m = do
res <- runController m
case res of
Result a -> return a
data InvalidPointerException = IPE
deriving (Show)
instance Throwable InvalidPointerException where
type OuterException InvalidPointerException = InvalidPointerException
type OtherExceptions InvalidPointerException = ()
getOuterException IPE = IPE
getOtherExceptions IPE = ()
test :: Int -> Throws InvalidPointerException IO String
test x = if x > 0
then lift $ return $ show (x*x)
else throw IPE
--
main :: IO ()
main = do
y <- try $
test (-3)
`except`
\IPE -> return "Exception!"
print y