FP_HSE2020Fall_12SimpleExcept

Fp12SimpleExcept.hs

{-# 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