LANGUAGE TypeFamilies FlexibleContexts MultiParamTypeClasse FlexibleIn

  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
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}
import Control.Monad.Trans
class (Eq e) => Throwable e where
type OuterException e
type OtherExceptions e
getOuterException :: e -> OuterException e
getOtherExceptions :: e -> OtherExceptions e
noException :: e
instance Throwable () where
type OuterException () = ()
type OtherExceptions () = ()
getOuterException () = ()
getOtherExceptions () = ()
noException = ()
instance (Throwable e1, Throwable e2) => Throwable (e1, e2) where
type OuterException (e1, e2) = e2
type OtherExceptions (e1, e2) = e1
getOuterException (e1,e2) = e2
getOtherExceptions (e1,e2) = e1
noException = (noException, noException)
class (Throwable e, Throwable e1) => Contains e e1 where
encapsulate :: e -> e1
instance (Throwable e) => Contains e e where
encapsulate e = e
instance (Throwable e1, Throwable e2) => Contains e1 (e1, e2) where
encapsulate e = (e, noException)
instance (Throwable e1, Throwable e2) => Contains e2 (e1, e2) where
encapsulate e = (noException, e)
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)
catchExceptions :: (Monad m, Contains e a1) => Throws e m a -> Throws a1 m a
catchExceptions cmd = Controller $ do
res <- runController cmd
case res of
Throw e -> return (Throw $ encapsulate e)
Result a -> return (Result a)
throw :: (Monad m, Throwable e, Throwable e1, Contains e e1) => e -> Throws e1 m a
throw e = Controller $ return (Throw $ encapsulate 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), Throwable (OuterException 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 -> let out = getOuterException e
in if out == noException
then throw $ getOtherExceptions e
else f out
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 | NoIPE
deriving (Eq, Show)
instance Throwable InvalidPointerException where
type OuterException InvalidPointerException = InvalidPointerException
type OtherExceptions InvalidPointerException = ()
getOuterException IPE = IPE
getOtherExceptions IPE = ()
noException = NoIPE
data AnotherException = AnotherException | NoAE
deriving (Eq, Show)
instance Throwable AnotherException where
type OuterException AnotherException = AnotherException
type OtherExceptions AnotherException = ()
getOuterException AnotherException = AnotherException
getOtherExceptions AnotherException = ()
noException = NoAE
-----------------------------------------------------------------------------------
test :: Int -> Throws InvalidPointerException IO String
test x = if x > 0
then lift $ return $ show (x*x)
else throw IPE
test2 :: Int -> Throws (AnotherException, InvalidPointerException) IO String
test2 x = if x < 7
then do
y <- catchExceptions $ test x
return $ y++"!!"
else throw AnotherException
main :: IO ()
main = do
-- y <- test2 (-1)
y <- try $
test2 (-1)
`except`
(\IPE -> return "Exception!")
`except`
\AnotherException -> return "Another exception!"
print y