src/Erebos/Error.hs


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

module Erebos.Error (
    ErebosError(..),
    showErebosError,

    FromErebosError(..),
    throwErebosError,
    throwOtherError,
) where

import Control.Monad.Except

import {-# SOURCE #-} Erebos.Network.Protocol


data ErebosError
    = ManyErrors [ ErebosError ]
    | OtherError String
    | UnhandledService ServiceID

showErebosError :: ErebosError -> String
showErebosError (ManyErrors errs) = unlines $ map showErebosError errs
showErebosError (OtherError str) = str
showErebosError (UnhandledService svc) = "unhandled service ‘" ++ show svc ++ "’"

instance Semigroup ErebosError where
    ManyErrors [] <> b = b
    a <> ManyErrors [] = a
    ManyErrors a <> ManyErrors b = ManyErrors (a ++ b)
    ManyErrors a <> b = ManyErrors (a ++ [ b ])
    a <> ManyErrors b = ManyErrors (a : b)
    a <> b = ManyErrors [ a, b ]

instance Monoid ErebosError where
    mempty = ManyErrors []


class FromErebosError e where
    fromErebosError :: ErebosError -> e
    toErebosError :: e -> Maybe ErebosError

instance FromErebosError ErebosError where
    fromErebosError = id
    toErebosError = Just

throwErebosError :: (MonadError e m, FromErebosError e) => ErebosError -> m a
throwErebosError = throwError . fromErebosError

throwOtherError :: (MonadError e m, FromErebosError e) => String -> m a
throwOtherError = throwErebosError . OtherError