О том как избежать успеха и как не избежать успеха…

Posted on May 20, 2016 with tags: haskell.

Успех сам себя не избежит

При всём богатстве возможностей в Haskell регулярно возникают проблемы с вещами, которые кажутся совершенно элементарными. Например получить стек вызовов в случае ошибки. Причём не то что бы его нельзя получить совсем, наоборот есть как минимум два ортогональных способа, но всё это сопряжено с таким количеством сложностей и условий, что проще воткнуть в нужные места printf’ы или густо обмазываться препроцессором. Особенно грустно дело с этим обстояло в ghci.

И вот для пользователей ghci наступает революция. Казалось бы страдания остались в прошлом, а error и undefined обрели практическое применение. Однако первая же попытка использовать это в массиве написанного кода обернулась неудачей: error и undefined выдавали стек вызовов, а броски исключения — нет. Сначала я подозревал себя в том, что куда-то не включил профилировочную информацию или как-то не так использую ImplicitParams, но потом я просто полез в код.

    -- ./libraries/base/GHC/Err.hs:77
    undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r).
                 HasCallStack => a
    undefined =  error "Prelude.undefined"

Тут всё понятно: undefined это такой частный случай error для тех кому не хватило фантазии написать осмысленное сообщение. Улыбаемся “Prelude.undefined” и двигаемся дальше.

    -- ./libraries/base/GHC/Err.hs:36
    error :: forall (r :: RuntimeRep). forall (a :: TYPE r).
             HasCallStack => [Char] -> a
    error s = raise# (errorCallWithCallStackException s ?callStack)

Тут в принципе ожидалось увидеть что-то вроде throw . ErrorCall, но не оно. С другой стороны raise# это такой primop, который реализует throw, так что errorCallWithCallStackException должен быть таким замысловатым способом сконструировать исключение. За подтверждением лезем в GHC.Exception.

    -- ./libraries/base/GHC/Exception.hs:171
    data ErrorCall = ErrorCallWithLocation String String
        deriving (Eq, Ord)

    pattern ErrorCall :: String -> ErrorCall
    pattern ErrorCall err <- ErrorCallWithLocation err _ where
      ErrorCall err = ErrorCallWithLocation err ""

    instance Exception ErrorCall

    instance Show ErrorCall where
      showsPrec _ (ErrorCallWithLocation err "") = showString err
      showsPrec _ (ErrorCallWithLocation err loc) = showString (err ++ '\n' : loc)

    errorCallException :: String -> SomeException
    errorCallException s = toException (ErrorCall s)

Первое что нас удивляет: конструктор ErrorCall теперь называется как-то по другому и таскает не одну строчку, а два. Впрочем если посмотреть тут то фокус с конструктором и синонимом становится понятен.

    -- ./libraries/base/GHC/Exception.hs:187
    errorCallWithCallStackException :: String -> CallStack -> SomeException
    errorCallWithCallStackException s stk = unsafeDupablePerformIO $ do
      ccsStack <- currentCallStack
      let
        implicitParamCallStack = prettyCallStackLines stk
        ccsCallStack = showCCSStack ccsStack
        stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack
      return $ toException (ErrorCallWithLocation s stack)

Теперь собственно виновник торжества. Получаем явный стек в качестве переменной, достаём стек профилировщика хакнув IO, красиво рисуем, склеиваем, запихиваем в расширенный ErrorCall вместе с сообщением, заворачиваем в SomeException. Если посмотреть на инстанс Show для ErrorCall, то можно увидеть код, который рисует стек если соответствующее поле заполнено. Снаружи никаких изменений в ErrorCall не видно. Отличный пример того как можно при помощи паттерн-синонимов в GHC8 можно изобразить инкапсуляцию. Теперь смотрим на throw.

    -- ./libraries/base/GHC/Exception.hs:166
    throw :: Exception e => e -> a
    throw e = raise# (toException e)

Ну конечно. Тут просто неоткуда взяться стек-трейсу. Да как бы он хранился в исключение произвольного типа? Разве что как-то так:

    data SomeException where
        SomeExceptionWithLocation :: Exception e => String -> e -> SomeException

    pattern SomeException :: () => Exception e => e -> SomeException
    pattern SomeException err <- SomeExceptionWithLocation _ err where
      SomeException err = SomeExceptionWithLocation "" err

Работать вокруг

Разобраться с тем почему ничего не работает хорошо, но было бы ещё лучше понять что нужно сделать чтобы оно заработало. В данном случае ответ простой: модифицировать стандартную библиотеку так, чтобы SomeException таскал за собой информацию о стеке вызовов[^1]. Однако, увы, у меня такой возможности нет. Можно вместо SomeException модифицировать типы исключений, которые выбрасываются в коде. Тогда придётся ещё и написать функцию, которая будет заполнять новый тип нужными данными. Также будем исходить из соображения, что нам лениво явным образом включать информацию о стеке вызовов в каждый тип исключение и мы напишем обёртку для всех исключений сразу.

> {-# LANGUAGE GADTs #-}
> {-# LANGUAGE ImplicitParams #-}

> import Control.Exception
> import Data.Typeable
> import GHC.Stack
> import System.IO.Unsafe

> data CallStackException where
>     CallStackException :: Exception e => e -> String -> CallStackException

> instance Exception CallStackException

Пока похоже на правду.

> instance Show CallStackException where
>     show (CallStackException e "")    = show e
>     show (CallStackException e stack) = show e ++ "\n" ++ stack

Наша обёртка не несёт никакого смысла для получателя исключения, так что показывать нам особо нечего. Если исключение прилетело без стек-трейса показываем только вложенное исключение. Если вместе со стек-трейсом то вложенное исключение и стек-трейс на следующей строке. Теперь нам нужен аналог throwIO.

> throwIO' :: (HasCallStack, Exception e) => e -> IO a
> throwIO' e = do
>     stack <- currentCallStack
>     throwIO $ CallStackException e $ if stack /= []
>         then prettyCallStack ?callStack ++ "\n" ++ renderStack stack
>         else prettyCallStack ?callStack

Вычитываем текущий стек вызовов профилировщика, выбрасываем наружу исключение в обёртке со стеком состоящем из ImplicitParams-стека и стека профилировщика, если он не пустой. Ничего интересного. Давайте для красоты добавим:

> throw' :: (HasCallStack, Exception e) => e -> a
> throw' = unsafeDupablePerformIO . throwIO'

Теперь можно бросить произвольное исключение и оно будет снабжено стеком вызовов. В принципе это уже весьма неплохо, поскольку в 80% случаев если обработка исключений и осуществляется, то на уровне onException. bracket и прочего finaly. Но положем мы всё же хотим ловить исключения по типу. У нас ничего не выйдет, поскольку в SomeException завёрнуто исключение не того типа который мы ловим, а типа-обёртки. Можно решить эту проблему двумя способами. Во-первых можно почитать документацию в Control.Exception и перегрузить toException и fromException для интересующих нас типов исключений таким образом чтобы он учитывал наличие обёртки. Но это придётся делать для каждого типа-исключения. Во-вторых мы можем написать свой волшебный catch:

> exceptionLoop :: (Exception a, Exception e) => e -> (a -> IO b) -> IO b -> IO b
> exceptionLoop ex f abort
>     | Just (SomeException inner)        <- cast ex = exceptionLoop inner f abort
>     | Just (CallStackException inner _) <- cast ex = exceptionLoop inner f abort
>     | Just v                            <- cast ex = f v
>     | otherwise                                    = abort

> catch' :: Exception e => IO a -> (e -> IO a) -> IO a
> catch' eval f = catch eval $
>      \err@(SomeException top) -> exceptionLoop top f (throwIO err)

Ловим все исключения и пытаемся их привести либо к тому типу который ждёт наш обработчик, либо к типам обёрткам. Если нашли обёртку, спускаемся уровнем ниже, если нашли нужный тип — обрабатываем, если не нашли ничего перебрасываем ровно то что получили с сохранением стека. Всё. Мы победили.

Радость правда омрачает то, что у нас есть свои собственные особые функции для того чтобы бросать и ловить исключения и нужно модифицировать весь существующий код. Конечно если он с самого начала был написан с помощью пакета exceptions, который вводит классы позволяющие перегрузить throwIO и catch для произвольной монады то ситуация выглядит существенно лучше, но модифицировать код для того чтобы его было проще отлаживать всё равно придётся. Кроме того, останутся вызовы throw в коде, который нами не управляется (например в стандартной библиотеке ввода-вывода). Это фейл.

Проблемы

Теперь, когда всем стало ясно, что во всём виноваты мейнтейнеры стандартной библиотеки стоит отметить пару проблем, которые так просто не решить.

Нарушение ссылочной прозрачности. Рассмотрим вот такой код:
```
eval `catch` (\ex@(T v) -> if pred v
    then makeGood
    else throwIO ex)
```
Нам кажется что в ветке else мы ничего не делаем, просто перебрасываем исключение, которое получили незаметно для кода выше по стеку. На самом деле мы только что обрезали стек вызовов до глубины catch. Конечно можно решить что всё ок и так нам и надо, но это не отменяет того что мы имеем малоочевидный побочный эффект.
А ещё есть асинхронные исключения, для которых вся эта ерунда вообще не применима. Ну то есть в throwTo безусловно можно вычитать текущий стек-трейс, но какой он имеет смысл для процесса в который исключение бросается? Можно опять же решить что всё ок и для асинхронного исключения стек вызовов не так уж и важен, но если кто-то из обработчиков этого исключения перебросит его как в предыдущем примере то в итоге мы получим стек вызовов означающий примерно ничего.