Skip to content

Instantly share code, notes, and snippets.

@deniok

deniok/Fp12SimpleExcept.hs Secret

Created Nov 27, 2020
Embed
What would you like to do?
FP_HSE2020Fall_12SimpleExcept
{-# LANGUAGE InstanceSigs #-}
module Fp12SimpleExcept where
import Control.Monad (liftM,ap,MonadPlus(mzero,mplus),guard)
import Control.Applicative (Alternative(empty,(<|>)))
--import Control.Monad.Error -- depricated начиная c ghc 7.10
--import Control.Monad.Trans.Except -- transformers
--import Control.Monad.Except -- mtl
import Data.Foldable (msum)
import Control.Monad.Fail (MonadFail(..))
--------------------------------------------------
-- здесь мы вручную реализуем монаду Except
-- полностью совместимую со стандартной (из transformers) по интерфейсу
--------------------------------------------------
newtype Except e a = Except { runExcept :: Either e a }
deriving Show
except :: Either e a -> Except e a
except = Except
--runExcept :: Except e a -> Either e a
instance Functor (Except e) where
fmap :: (a -> b) -> Except e a -> Except e b
fmap = liftM
instance Applicative (Except e) where
pure :: a -> Except e a
pure = return
(<*>) :: Except e (a -> b) -> Except e a -> Except e b
(<*>) = ap
instance Monad (Except e) where
return :: a -> Except e a
return a = except $ Right a
(>>=) :: Except e a -> (a -> Except e b) -> Except e b
m >>= k = case runExcept m of
Left e -> except $ Left e
Right x -> k x
fail :: String -> Except e a
fail _ = error "I am Monad.fail"
instance MonadFail (Except e) where
fail :: String -> Except e a
fail _ = error "I am MonadFail.fail"
throwE :: e -> Except e a
throwE = except . Left
catchE :: Except e a -> (e -> Except e' a) -> Except e' a -- !!
m `catchE` h = case runExcept m of
Left l -> h l
Right r -> except $ Right r
instance Monoid e => Alternative (Except e) where -- !!
empty :: Except e a
empty = mzero
(<|>) :: Except e a -> Except e a -> Except e a
(<|>) = mplus
instance Monoid e => MonadPlus (Except e) where -- !!
mzero :: Except e a
mzero = except $ Left mempty
mplus :: Except e a -> Except e a -> Except e a
x `mplus` y = except $ let alt = runExcept y in
case runExcept x of
Left e -> either (Left . mappend e) Right alt
r -> r
{-
Семантика:
mzero - ошибка по умолчанию, задается mempty
mplus - накапливает ошибки слева направо, но если происходит удачная попытка, то возвращает удачу. -- !!
-}
---------------------------------------------------
data DivByError = ErrZero | Other String
deriving (Eq,Show)
(/?) :: Double -> Double -> Except DivByError Double
_ /? 0 = throwE ErrZero
x /? y = return $ x / y
example0 :: Double -> Double -> Except DivByError String
example0 x y = action `catchE` handler where
action = do
q <- x /? y
return $ show q
handler = return . show
{-
GHCi> runExcept $ example0 5 2
Right "2.5"
GHCi> runExcept $ example0 5 0
Right "ErrZero"
-}
instance Semigroup DivByError where
Other s1 <> Other s2 = Other $ s1 ++ s2
Other s1 <> ErrZero = Other $ s1 ++ "zero;"
ErrZero <> Other s2 = Other $ "zero;" ++ s2
ErrZero <> ErrZero = Other $ "zero;zero"
instance Monoid DivByError where
mempty = Other ""
example2 :: Double -> Double -> Except DivByError String
example2 x y = action `catchE` handler where
action = do
q <- x /? y
guard $ y>=0
return $ show q
handler = return . show
{-
GHCi> runExcept $ example2 5 2
Right "2.5"
GHCi> runExcept $ example2 5 0
Right "ErrZero"
GHCi> runExcept $ example2 5 (-2)
Right "Other \"\""
GHCi> runExcept $ msum [5/?0, 7/?0, 2/?0]
Left (Other "zero;zero;zero;")
GHCi> runExcept $ msum [5/?0, 7/?0, 2/?4]
Right 0.5
-}
test :: [Except DivByError Double] -> Either DivByError Double
test = runExcept . msum
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment