FP_HSE2020Fall_12

Fp12.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

module Fp12 where
import Control.Applicative (Alternative(empty, (<|>)))
import Control.Monad (guard, MonadPlus(..), ap, liftM)
import Control.Monad.State
    (StateT, MonadState(get, put), modify, MonadTrans(..), State)
 
-- мы используем библиотеку mtl, а не transformers, 
-- для transformers следовало бы писать
--import Control.Monad.Trans.State
import Control.Monad.Identity ( Identity(..) )

--import Control.Monad.Error -- depricated начиная c ghc 7.10 
import Control.Monad.Except
    ( Except, runExcept,  MonadError(catchError, throwError) )
import Data.Foldable (msum)    

import Control.Monad.Fail ( MonadFail(..) )

pythags :: [(Integer, Integer, Integer)]
pythags = do
  z <- [1..]
  x <- [1..z]
  y <- [x..z]
  guard $ x^2 + y^2 == z^2
  return (x, y, z)

{-
GHCi> take 5 pythags
[(3,4,5),(6,8,10),(5,12,13),(9,12,15),(8,15,17)]
-}

--------------------------------------------------
-- монада Except
data DivByError = ErrZero | Other String
                   deriving (Eq,Show)
                   
(/?) :: Double -> Double -> Except DivByError Double
_ /? 0 = throwError ErrZero                        -- в mtl throwError, в transformers throwE
x /? y = return $ x / y

example0 :: Double -> Double -> Except DivByError String
example0 x y = action `catchError` handler where   -- в mtl catchError, в transformers catchE
  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 `catchError` handler where    -- в mtl catchError, в transformers catchE
  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

{-
GHCi> do {x<-(*2); y<-ask; return (x+y)} $ 5
15
GHCi> Left 5 `catchError` (\e -> Right (e^2))
Right 25
GHCi> Right 5 `catchError` (\e -> Right (e^2))
Right 5
>
-}

--------------------------------------------------
-- Многопараметрические классы типов

data Vector = Vector Int Int 
               deriving (Eq, Show)
data Matrix = Matrix Vector Vector 
               deriving (Eq, Show)

-- требуются расширения MultiParamTypeClasses, FunctionalDependencies (второе влечет первое:)
class Mult a b c | a b -> c where
  (***) :: a -> b -> c
 
instance Mult Matrix Matrix Matrix where
  Matrix (Vector a11 a12) (Vector a21 a22) *** Matrix (Vector b11 b12) (Vector b21 b22) =
    Matrix (Vector c11 c12) (Vector c21 c22) where
      c11 = a11 * b11 + a12 * b21
      c12 = a11 * b12 + a12 * b22
      c21 = a21 * b11 + a22 * b21
      c22 = a21 * b12 + a22 * b22
 
{-
GHCi> let a = Matrix (Vector 1 2) (Vector 3 4)
GHCi> let i = Matrix (Vector 1 0) (Vector 0 1)
GHCi> a *** i
Matrix (Vector 1 2) (Vector 3 4)
-}


--------------------------------------------------------
-- Трансформеры монад 
--(мы используем библиотеку mtl, а не transformers)

stInteger :: State Integer Integer       
stInteger = do modify (+1)
               get
         
stString :: State String String       
stString = do modify (++"1")
              get

{-
GHCi> evalState stInteger 0
1
GHCi> evalState stString "0"
"01"
-}

stComb :: StateT Integer (StateT String Identity) (Integer, String)      
stComb = do modify (+1)
            lift $ modify (++"1")
            a <- get
            b <- lift get
            return (a,b)

{-
GHCi> runIdentity $ evalStateT (evalStateT stComb 0) "0"
(1,"01")
-}

-----------------------------------
newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }

instance Monad m => Monad (MaybeT m) where
  return  = lift . return
  mx >>= k = MaybeT $ do
    v <- runMaybeT mx
    case v of
      Nothing -> return Nothing
      Just y  -> runMaybeT (k y)
--  fail _  = MaybeT $ return Nothing  -- для старых компиляторов; 
--  fail  = Control.Monad.Fail.fail    -- теперь все происходит так

{-
Из-за MonadFail Proposal надо еще написать
-}
instance Monad m => MonadFail (MaybeT m) where
  fail _  = MaybeT $ return Nothing
{-
Если же семантика имплементируемого трансформера не подразумевает умения 
обрабатывать ошибки, то все равно необходимо протащить fail из внутренней 
монады, если он там есть - то есть контекст представителя должен быть  (MonadFail m).
-}

{-
Из-за AMP надо еще написать
-}
instance Monad m => Functor (MaybeT m) where
  fmap  = liftM
instance Monad m => Applicative (MaybeT m) where
  pure = return
  (<*>) = ap

instance MonadTrans MaybeT where
  lift = MaybeT . fmap Just
{-
GHCi> :t liftM Just
liftM Just :: Monad m => m a -> m (Maybe a)
GHCi> :t liftM Just get
liftM Just get :: MonadState a m => m (Maybe a)
-}
  
mbSt :: MaybeT (StateT Integer Identity) Integer      
mbSt = do 
  lift $ modify (+1)
  a <- lift get
  True <- return $ a >= 3
  --guard (a >= 3)
  return a
{-  
GHCi> runIdentity $ evalStateT (runMaybeT mbSt) 0
Nothing
GHCi> runIdentity $ evalStateT (runMaybeT mbSt) 2
Just 3
-}

-- Чтобы заработал guard нужно сделать MaybeT m представителем Alternative.
-- (Начиная с GHC 7.10 guard определен через Alternative, а не MonadPlus.)
instance Monad m => Alternative (MaybeT m) where
  empty = MaybeT $ return Nothing
  x <|> y = MaybeT $ do
    v <- runMaybeT x
    case v of
      Nothing -> runMaybeT y
      Just _  -> return v

-- Это необязательно, но может пригодиться для msum, mfilter
instance Monad m => MonadPlus (MaybeT m)
      
mbSt' :: MaybeT (State Integer) Integer
mbSt' = do lift $ modify (+1)
           a <- lift get
           guard $ a >= 3 -- !!
           return a
{-
GHCi> runIdentity $ evalStateT (runMaybeT mbSt') 0
Nothing
GHCi> runIdentity $ evalStateT (runMaybeT mbSt') 2
Just 3
-}

-- Для любой пары монад можно избавиться от подъёма 
-- стандартных операций вложенной монады

{-
class Monad m => MonadState s m | m -> s where
    get :: m s
    get = state (\s -> (s, s))
    
    put :: s -> m ()
    put s = state (\_ -> ((), s))
    
    state :: (s -> (a, s)) -> m a
    state f = do
      s <- get
      let ~(a, s') = f s
      put s'
      return a

modify :: MonadState s m => (s -> s) -> m ()
modify f = state (\s -> ((), f s))

gets :: MonadState s m => (s -> a) -> m a
gets f = do
    s <- get
    return (f s)

-}

-- требуются расширения FlexibleInstances, UndecidableInstances
instance MonadState s m => MonadState s (MaybeT m) where
  get = lift get
  put = lift . put


mbSt'' :: MaybeT (State Integer) Integer
mbSt'' = do 
  modify (+1) -- без lift
  a <- get -- без lift
  guard $ a >= 3
  return a
{-
GHCi> runIdentity $ evalStateT (runMaybeT mbSt'') 0
Nothing
GHCi> runIdentity $ evalStateT (runMaybeT mbSt'') 2
Just 3
-}