sc-lectures/4.md

theme	author
superblack	Ilya Kostyuchenko

Функциональное программирование

---

Напоминалочка

class Functor f where
  fmap :: (a -> b) -> f a -> f b

class Functor f => Applicative f where
  (<*>) :: f (a -> b) -> f a -> f b
  pure :: a -> f a

class Applicative f => Monad f where
  (>>=) :: f a -> (a -> f b) -> f b
  return :: a -> f a

---

Either

data Either a b = Left a | Right b

throwError :: e -> Either e a
throwError = Left

data PaymentError = InsufficientBalance

pay :: Balance -> Price -> Either PaymentError Balance
pay balance price = do
  let newBalance = balance - price
  when (newBalance < 0) (throwError InsufficientBalance)
  return newBalance

when :: (Applicative f) => Bool -> f () -> f ()
when p s  = if p then s else pure ()

---

State

data State s a = State { runState :: s -> (a, s) }

get :: State s s
get = State (\s -> (s, s))

put :: s -> State s ()
put s = State (\_ -> (_, s))

---

getNewId :: State TransactionId TransactionId
getNewId = do
  newId <- get
  put (succ newId)
  return newId

data Transaction = Transaction
  { transactionId :: TransactionId,
    transactionAmount :: Price
  }

registerPayment :: Price -> State TransactionId Transaction
registerPayment price = do
  newId <- getNewId
  return Transaction
    { transactionId = newId
      transactionAmount = price
    }

---

registerPayment :: Price -> State TransactionId Transaction
pay :: Balance -> Price -> Either PaymentError Balance

payAndRegister balance price = do
  newBalance <- pay balance price
  transacation <- registerPayment price
  return (newBalance, transaction)

(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)

-- Такого нет
(>=>)
  :: (Monad m, Monad n)
  => (a -> m b) -> (b -> n c) -> (a -> ? c)

[На каждый чих нужно создавать новый тип?]{.fragment}

---

Мы хотим:

1. Отделить эффекты от конкретной монады
2. Получить возможность комбинировать разные эффекты

[(И чтобы не надо было на каждый случай новый тип создавать)]{.fragment}

---

registerPayment :: Price -> State TransactionId Transaction
pay :: Balance -> Price -> Either PaymentError Balance

registerPayment
  :: MonadState TransactionId m
  => Price -> m Transaction
pay
  :: MonadError PaymentError m
  => Balance -> Price -> m Balance

payAndRegister
  :: (MonadState TransactionId m, MonadError PaymentError m)
  => Balance -> Price -> m (Balance, Transaction)

---

На самом деле мы хотим чтобы понятие "state" не было привязано к конкретной монаде.

[Мы хотим чтобы "базовые операции" не были привязаны к конкретной монаде.]{.fragment}

-- Было
get :: State s s
put :: s -> State s ()

-- Стало
get :: MonadState s m => m s
put :: MonadState s m => s -> m ()

---

MonadState

---

class Monad m => MonadState s m where
  get :: m s
  put :: s -> m ()

data State s a = State { runState :: s -> (a, s) }

instance MonadState s (State s) where
  get = State (\s -> (s, s))
  put s = State (\_ -> ((), s))

getNewId :: MonadState TransactionId m => m TransactionId
getNewId = do
  newId <- get
  put (succ newId)
  return newId

registerPayment :: Price -> State TransactionId Transaction
registerPayment price = do
  newId <- getNewId
  return Transaction
    { transactionId = newId
      transactionAmount = price
    }

---

MonadError

class Monad m => MonadError e m where
  throwError :: e -> m a
  catchError :: m a -> (e -> m a) -> m a

data Either e a = Left e | Right a

instance MonadError e (Either e) where
  throwError e = Left e

  catchError (Left e) f = f e
  catchError (Right a) _ = Right a

---

Мы хотим:

1. Отделить эффекты от конкретной монады
2. Получить возможность комбинировать разные эффекты

---

Начнем с функторов

data Compose f g a = Compose { getCompose :: f (g a) }

type ErrorStateFunctor a =
  Compose (Either PaymentError) (State TransactionId) a

-- Compose
--   { getCompose ::
--       Either PaymentError (State TransactionId a)
--   }

instance (Functor f, Functor g) =>Functor (Compose f g) where
  fmap f (Compose x) = Compose (fmap (fmap f) x)

[🎉]{ .fragment }

[(Applicative тоже можно -- можете сами попробовать)]{ .fragment }

---

К монадам!

instance (Monad f, Monad g) => Monad (Compose f g) where
  return x = Compose (return (return x))
  (Compose x) >>= f = ???

[😢]{ .fragment }

[Все равно хочется!]{ .fragment }

---

data Compose f g a = Compose { getCompose :: f (g a) }

[Для такого не можем]{ .fragment }

data ErrorState e s a =
  ErrorState { runErrorState :: State s (Either e a) }

[А для такого можем!]{ .fragment }

(State s (Either e a)) ~ (s -> Either e (a, s))

---

data ErrorState e s a =
  ErrorState { runErrorState :: State s (Either e a) }

[Хочется чтобы можно было не только Either!]{ .fragment }

data State  s   a = State  { runState  :: s ->   (a, s) }

data StateT s m a = StateT { runStateT :: s -> m (a, s) }

instance (Monad m) => Monad (StateT s m) where
  return a = StateT $ \ s -> return (a, s)

  m >>= f = StateT (\s -> do
    (a, s') <- runStateT m s
    runStateT (f a) s'
    )

---

Transformers!

{height=400px}

---

Вернем операции!

class Monad m => MonadState s m where
  get :: m s
  put :: s -> m ()

data StateT s n a = StateT { runStateT :: s -> n (a, s) }

instance Monad n => MonadState s (StateT s n) where
  get = StateT (\s -> return (s, s))
  put s = StateT (\_ -> return ((), s)

---

Error

data ExceptT e n a = ExceptT { runExceptT :: n (Either e a) }

class Monad m => MonadError e m where
  throwError :: e -> m a
  catchError :: m a -> (e -> m a) -> m a

instance Monad n => MonadError e (ExceptT e n) where
  throwError e = ExceptT (return (Left e))

  catchError (ExceptT n) f = ExceptT $ do
    x <- n
    case x of
      Left e -> runExceptT (f e)
      Right a -> return (Right a)

---

class Monad m => MonadError e m where
  throwError :: e -> m a
  catchError :: m a -> (e -> m a) -> m a

data PaymentError = InsufficientBalance

pay :: MonadError e m => Balance -> Price -> m Balance
pay balance price = do
  let newBalance = balance - price
  when (newBalance < 0) (throwError InsufficientBalance)
  return newBalance

---

The states

data State  s   a = State  { runState  :: s ->   (a, s) }

data StateT s m a = StateT { runStateT :: s -> m (a, s) }

[🤔]{.fragment}

---

Напоминалочка:

data Identity a = Identity { runIdentity :: a }

(Identity a) ~ a

data State  s   a = State  { runState  :: s ->   (a, s) }

data StateT s m a = StateT { runStateT :: s -> m (a, s) }

(StateT s Identity a) ~ (s -> Identity (a, s))

[🤔]{.fragment}

(s -> Identity (a, s)) ~ (s -> (a, s)) ~ (State s a)

type State s a = StateT s Identity a

---

data ExceptT e n a = ExceptT { runExceptT :: n (Either e a) }

data StateT s m a = StateT { runStateT :: s -> m (a, s) }

class Monad m => MonadError e m where
  throwError :: e -> m a
  catchError :: m a -> (e -> m a) -> m a

class Monad m => MonadState s m where
  get :: m s
  put :: s -> m ()

Пришли к тому, с чего начинали, только еще сложнее

---

1. Отделить эффекты от конкретной монады
2. Получить возможность комбинировать разные эффекты

---

foo :: ExceptT Bool (State Char) Int
foo = do
  c <- get -- :: State Char Char
  throwError True -- :: ExceptT Bool (State Char) Int

(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)

-- Такого нет
(>=>)
  :: (Monad m, Monad n)
  => (a -> m b) -> (b -> n c) -> (a -> ? c)

lift :: State Char a -> ExceptT Bool (State Char) a

foo :: ExceptT Bool (State Char) Int
foo = do
  c <- lift get -- :: ExceptT Bool (State Char) Int
  throwError True -- :: ExceptT Bool (State Char) Int

---

class MonadTrans t where
    lift :: (Monad m) => m a -> t m a

lift :: State Char a -> ExceptT Bool (State Char) a
--      (m       ) a -> (t         ) (m         ) a

instance MonadTrans (StateT s) where
  lift m = StateT $ \ s -> do
    a <- m
    return (a, s)

instance MonadTrans (ExceptT e) where
  lift m = ExceptT (fmap Right m)

foo :: ExceptT Bool (State Char) Int
foo = do
  c <- lift get
  throwError True

---

Но хочется чтобы без lift 🙂

foo :: ExceptT Bool (State Char) Int
foo = do
  c <- get
  throwError True

[Нужен инстанс MonadState для ExceptT]{ .fragment }

instance MonadState s n => MonadState s (ExceptT e n) where
    get = lift get
    put s = lift (put s)

---

registerPayment
  :: State TransactionId m
  => Price -> m Transaction
pay
  :: MonadError PaymentError m
  => Balance -> Price -> m Balance

payAndRegister
  :: (State TransactionId m, MonadError PaymentError m)
  => Balance -> Price -> m (Balance, Transaction)
payAndRegister balance price = do
  newBalance <- pay balance price
  transacation <- registerPayment price
  return (newBalance, transaction)

---

Как это "запускать"?

payAndRegister
  :: (State TransactionId m, MonadError PaymentError m)
  => Balance -> Price -> m (Balance, Transaction)

myBalance :: Balance
myPrice :: Price

balanceAndTransaction
  :: Either PaymentError (Balance, Transaction)

data ExceptT e n a = ExceptT { runExceptT :: n (Either e a) }
data StateT s n a = StateT { runStateT :: s -> n (a, s) }

balanceAndTransaction =
  runStateT 0 (payAndRegister myBalance myPrice)

---

payAndRegister
  :: (State TransactionId m, MonadError PaymentError m)
  => Balance -> Price -> m (Balance, Transaction)

data StateT s n a = StateT { runStateT :: s -> n (a, s) }

balanceAndTransaction
  :: Either PaymentError (Balance, Transaction)
balanceAndTransaction =
  flip runStateT 0 (payAndRegister myBalance myPrice)

  flip runStateT 0 (payAndRegister myBalance myPrice)
-- ^-------------^
-- StateT TransactionId n a -> n a

-- (n a) ~ (Either PaymentError (Balance, Transaction))

flip runStateT 0 (payAndRegister myBalance myPrice)
--               ^--------------------------------^
--                    StateT TransactionId
--                      (Either PaymentError)
--                      (Balance, Transaction)

---

payAndRegister
  :: (State TransactionId m, MonadError PaymentError m)
  => Balance -> Price -> m (Balance, Transaction)

data ExceptT e n a = ExceptT { runExceptT :: n (Either e a) }
data StateT s n a = StateT { runStateT :: s -> n (a, s) }
data Identity a = Identity { runIdentity :: a }

balanceAndTransaction
  :: Either PaymentError (Balance, Transaction)
balanceAndTransaction =
  (runIdentity . runExceptT . flip runStateT 0)
    (payAndRegister myBalance myPrice)

---

А теперь мы пойдем в совершенно другом направлении!

---

Напоминалочка

class Show a where
  show :: a -> String

data Foo = Bar { barInt :: Int }
  deriving Show

show (Bar 8)
-- Bar {barInt = 8}

---

Read

Обратная операция к show

read :: Read a => String -> a

class Read a where
  readsPrec
    :: -- | Приоритет контекста выражения
       Int
    -> String
    -> [(a, String)]

data Foo = Bar { barInt :: Int }
  deriving (Show, Read)

read "Bar {barInt = 8}"
-- Bar { barInt = 8 }

---

Монады

1. Базовые операции монады (эффекты)

[MonadState, MonadErrror]{ .fragment }

2. Конкретные монады (переносчик) (и способы их "разворачивать")

[StateT (runStateT), Either, ExceptT (runExceptT)]{ .fragment }

[Переводят эффекты в pure код]{ .fragment }

---

Монада IO

[Обладает только базовыми операциями]{ .fragment } [(Невозможно перевести в pure код)]{ .fragment }

getLine :: IO String

putStrLn :: String -> IO ()

type FilePath = String

readFile :: FilePath -> IO String

writeFile :: FilePath -> String -> IO ()

---

add10FromConsole :: IO ()
add10FromConsole = do
  x <- getLine
  let
    n :: Int
    n = read x
  putStrLn (show (n + 10))

---

"Разворачивать" IO умеет только рантайм.

main :: IO ()
main = add10FromConsole

> 10
20

---

-- Как 'read', но не взрывается в рантайме
readMaybe :: Read a => String -> Maybe a

accumulateNums :: StateT Int IO ()
accumulateNums = do
  x <- lift getLine
  case (readMaybe x :: Int) of
    Nothing -> do
      s <- get
      lift (putStrLn (show s))
    Just x' -> do
      modify (+ x')
      accumulateNums

main :: IO ()
main = flip runStateT 0 accumulateNums

> 8
> 3
> a
11

---

accumulateNums :: StateT Int IO ()

-- Хочется так, но где тут взять 'IO'?
accumulateNums :: MonadState Int m => m ()

[Трансформера IO нет.]{ .fragment }

[Тогда lift!]{ .fragment }

[Но lift поднимает строго на один уровень.]{ .fragment }

---

class MonadIO m where
  liftIO :: IO a -> m a

accumulateNums :: (MonadState Int m, MonadIO m) => m ()
accumulateNums = do
  x <- liftIO getLine
  case (readMaybe x :: Int) of
    Nothing -> do
      s <- get
      liftIO (putStrLn (show s))
    Just x' -> do
      modify (+ x')
      accumulateNums

main :: IO ()
main = flip runStateT 0 accumulateNums

> 8
> 3
> a
11