Привет, Хабр.

Итак, в прошлый раз мы эмпирически доказали, что на хаскеле можно довольно легко написать этакий игрушечный wc, который при этом существенно быстрее реализации wc из GNU Coreutils. Понятное дело, что это не совсем честное сравнение: наша программа не умеет ничего, кроме подсчёта байт, строк и слов, тогда как настоящий wc куда мощнее: он имеет ещё несколько статистик, поддерживает опции, умеет читать из stdin… Короче, у нас действительно получилась всего лишь игрушка.

Сегодня мы это исправим. Наша главная цель — позволить пользователю выбирать конкретные статистики для подсчёта, при этом не считая то, что пользователю не нужно. А самое главное — мы будем стремиться к модульности, выделяя каждую статистику в отдельный изолированный юнит.

Действительно, если мы посмотрим на C-версию — ну, лично я бы не назвал это образцом читаемого и поддерживаемого кода, так как там всё происходит в одной большой функции на 370 строк. Мы будем стараться этого избежать.

Основная функция С-версии не влезла на 4k-экран в портретной ориентации 4-м шрифтом.

Кроме этой модуляризации мы, среди прочего:

• выразим идею, что некоторые статистики вроде подсчёта числа байт могут работать эффективнее на всём входе целиком, а другие должны смотреть на каждый байт;
• реализуем ещё больше статистик, наслаждаясь возможностью рассуждать о каждой из них в отдельности (то, что называют local reasoning);
• напишем немного тестов, наслаждаясь local reasoning'ом ещё раз;
• испытаем некоторые почти зависимо типизированные техники, успешно получив корректно работающий, но феерически тормозящий код;
• поиграем с Template Haskell;
• полюбуемся (не)предсказуемостью и (не)воспроизводимостью производительности результирующего кода.

На всякий случай вспомним, чем мы закончили предыдущий пост:

{-# LANGUAGE Strict #-}
{-# LANGUAGE RecordWildCards #-}

module Data.WordCount where

import qualified Data.ByteString.Lazy as BS

data State = State
  { bs :: Int
  , ws :: Int
  , ls :: Int
  , wasSpace :: Int
  }

wc :: BS.ByteString -> (Int, Int, Int)
wc s = (bs, ws + 1 - wasSpace, ls)
  where
    State { .. } = BS.foldl' go (State 0 0 0 1) s

    go State { .. } c = State (bs + 1) (ws + addWord) (ls + addLine) isSp
      where
        isSp | c == 32 || c - 9 <= 4 = 1
             | otherwise = 0
        addLine | c == 10 = 1
                | otherwise = 0
        addWord = (1 - wasSpace) * isSp
{-# INLINE wc #-}

Мы хотим разбить эту функцию на отдельные кусочки, считающие соответственно количество байт, слов и строк. Как этого можно добиться?

Композабельные левые свёртки

В первую очередь заметим, что основная часть нашего алгоритма выражается как свёртка. В самом деле, об этом говорит даже название функции BS.foldl'!

Некоторое время назад я наткнулся на библиотеку foldl, предназначенную для «композабельных, потоковых и эффективных левых свёрток». Это ровно то, что нам нужно! Более того, к счастью, в этой библиотеке даже есть отдельный модуль для свёрток по ByteString. В частности, в этом модуле есть две из трёх нужных нам статистик: количество байт равно длине входной строки (то есть, length в этом модуле), а количество строк можно посчитать при помощи функции count (через count 10). Похоже, осталось реализовать свёртку для подсчёта слов, и мы в дамках!

Для того, чтобы реализовать эту свёртку, можно взять нашу исходную функцию и просто выкинуть из неё всё лишнее. Вот так в итоге выглядит результат:

{-# LANGUAGE Strict #-}

import qualified Control.Foldl as L
import qualified Data.ByteString as BS

data WordState = WordState { ws :: Int, wasSpace :: Int }

wordsCount :: L.Fold BS.ByteString Int
wordsCount = L.Fold (BS.foldl' go) (WordState 0 1) (\WordState { .. } -> ws + 1 - wasSpace)
  where
    go WordState { .. } c = WordState (ws + addWord) isSp
      where
        isSp | c == 32 || c - 9 <= 4 = 1
             | otherwise = 0
        addWord = (1 - wasSpace) * isSp

Тогда посчитать байты, строки и слова одновременно можно так:

import qualified Control.Foldl.ByteString as BL

main :: IO ()
main = do
  [path] <- getArgs
  contents <- unsafeMMapFile path
  let res = BL.fold ((,,) <$> BL.length <*> BL.count 10 <*> wordsCount) (BSL.fromStrict contents) :: (Int, Int, Int)
  print res

Композабельно! Но насколько эффективно?

Если бенчмаркать так же, как описано в предыдущем посте (запуская пять раз на 1.8-гигабайтовом файле, находящемся в tmpfs-разделе для устранения IO, и выбирая наилучший результат), то на моей машине получится в районе 2.5 секунд. Кстати, надо для честности отметить, что это машина с другим процессором, чем использованная в прошлом посте (хотя скорость работы что оригинального wc, что результата усилий из прошлого поста на ней отличается несущественно), да и ней есть куча источников шума вроде запущенного браузера или IDE, но для составления общей картины о характеристиках кода и иллюстрации идеи поста этого хватит.

Итак, 2.5 секунд. Почти вдвое хуже, чем было раньше.

Что, если мы посчитаем только лишь длину и количество слов?

  let res = BL.fold ((,) <$> BL.length <*> wordsCount) contents :: (Int, Int)
  print res

1.55 секунд. Хмм. Что насчёт количества строк?

  let res = BL.fold (BL.count 10) contents :: Int
  print res

1.05 секунд.

Чёрт. Оно практически аддитивно. Но оно не должно быть аддитивно! Например, подсчёт количества строк (сводящийся к подсчёту количества '\n') должен затмеваться куда более сложной логикой подсчёта количества слов, но мы этого не наблюдаем.

Плохо. Чтобы понять, что происходит, засучим рукава и залезем в кишки библиотеки foldl.

foldl реализован следующим образом. Он берёт каждый чанк входа и скармливает его каждой из свёрток в композиции. В случае строк foldl бегает по ленивым ByteString'ам, которые примерно изоморфны списку строгих ByteString'ов, каждая из которых и является чанком. В данном конкретном случае размер чанка — 256 килобайт, что не влезает в L1-кэш, так что мы вынуждены платить за перемещение данных из L2 в L1 (и даже за перемещение из L1 в регистры).

Мы, конечно, могли бы уменьшить размер чанка до 16-32 килобайт, чтобы он помещался в L1, но это не так интересно.

И, что гораздо хуже, компилятор, похоже, не может оптимизировать лишние вычисления: время работы BL.fold ((,) <$> wordsCount <*> wordsCount) contents (то есть, двойного подсчёта слов) вдвое больше времени BL.fold wordsCount contents. Так что от этого подхода мы вынуждены отказаться.

Кроме того, неочевидно, как совмещать свёртки «по запросу», например, на основании опций командной строки.

Так что давайте напишем...

Наши собственные свёртки

Перед тем, как бросаться к редактору кода, давайте немного подумаем о дизайне. В итоге мы хотим строить композиции свёрток на основе рантайм-выбора пользователя. Как это может выглядеть?

Пусть у нас есть какие-то базовые «атомарные» свёртки (то есть, статистики) f1, f2, f3, и пользователю нужна композиция f1 и f3. Думаю, даже компиляторы функциональных языков ещё долго будут не настолько умны, чтобы понять, что код вроде

  -- options — список булевых значений, соответствующих атомарным свёрткам
  options <- parseCliOptions

  -- theFold — результирующая композиция
  let theFold = foldl' f (zip options [f1, f2, f3]) emptyFold
  where
    f acc (True, stat) = acc `compose` stat
    f acc (False, _) = acc

означает, что необходимо специализировать все возможные композиции свёрток, которые тут могут возникнуть.

Единственный способ быть уверенным, что у компилятора достаточно информации — поднять всё это на уровень типов. Хаскель в итоге избавляется от типов на этапе компиляции, так что любая информация, выраженная через типы, оказывается доступна компилятору.

Типы на помощь

Так как нам представить свёртку?

Один дружественный к типам способ — через тайпкласс. Только перед тем, как обсуждать тайпклассы, давайте сразу упомянем необходимые в дальнейшем расширения системы типов, чтобы потом на них не отвлекаться:

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, FlexibleInstances #-}
{-# LANGUAGE TypeFamilyDependencies, FunctionalDependencies, PolyKinds, DataKinds, GADTs, TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}

Что на самом деле является свёрткой-статистикой в нашем случае? Статистика состоит из:

• начального состояния,
• функции-шага, обновляющей состояние согласно входному символу,
• функции для превращения состояния в окончательный ответ-результат,
• типов состояния и результата.

Давайте это запишем:

class Statistic s res st | res -> s, st -> s
                         , s -> res, s -> st
                         where
  initState :: st
  extractState :: st -> res
  step :: st -> Word8 -> st

где s обозначает идентификатор статистики (чуть позже это будет штука из DataKinds), и мы используем функциональные зависимости для выражения того, что статистика единственным образом определяет типы состояния и результата, и наоборот. В частности, это освобождает нас от потребности перечислять все типы-параметры тайпкласса в каждом методе: иначе нам бы пришлось писать

  initState :: proxy1 s -> proxy2 res -> st
  extractState :: proxy s -> st -> res
  step :: proxy1 s -> proxy2 res -> st -> Word8 -> st

К счастью, функциональные зависимости позволяют компилятору вывести все переменные типов, даже если упомянута всего одна из них, так что мы можем писать короткие и ясные сигнатуры.

Кстати, заметим, что мы могли бы пользоваться и куда более мощными и общими семействами типов, что дало бы инъективность в одну из сторон, но выражение статистик через мультипараметрический тайпкласс с функциональными зависимостями кажется мне более интуитивным и естественным в этой задаче.

Статистики по чанкам

Пока всё вроде бы неплохо, но кое-чего не хватает. Давайте подумаем, как бы мы могли выразить, например, подсчёт количества байт. Если пользователь запросил только эту статистику, то нам совершенно не обязательно побайтово пробегать всю строку, инкрементируя счётчик на каждой итерации. Вместо этого мы могли бы просто взять длину всей строки и радоваться жизни, сведя сложность задачи с $$ до $$. С другой стороны, подсчёт слов (или, что ещё сложнее, подсчёт максимальной длины строки) не имеет подобной легко выразимой «чанковой» структуры (если не рассматривать различные хитроумные SIMD-реализации, анализ которых сильно вне темы этого поста). Кроме того, чуть позже мы захотим совмещать статистики. Если все из них поддерживают чанковый режим вычислений, то и результат тоже его поддерживает, а иначе придётся откатиться до побайтового анализа.

Так как мы можем выразить, что некоторые статистики поддерживают и чанковый, и побайтовый режим вычислений, тогда как другие обязаны вычисляться побайтово? Здесь нам поможет GADT! Мы добавим тип-перечисление для определения режима подсчёта статистик, и мы также определим GADT для хранения тех функций, которые имеют смысл для данного режима. Или в коде:

data StatCompTyOf = Chunked | ByteOnly

data StatComputation st compTy where
  ChunkedComputation :: (st -> Word8 -> st)
                     -> (st -> BS.ByteString -> st)
                     -> StatComputation st 'Chunked
  ByteOnlyComputation :: (st -> Word8 -> st)
                      -> StatComputation st 'ByteOnly

Здесь (и в последующем изложении) BS — модуль, соответствующий строгим байтовым строкам.

Мы также поменяем наш класс Statistic, добавив туда ещё один параметр comp и заменив метод step на более общий computation:

class Statistic s res st comp | res -> s, st -> s
                              , s -> res, s -> st, s -> comp
                              where
  initState :: st
  extractState :: st -> res
  computation :: StatComputation st comp

И здесь нам снова помогают функциональные зависимости. Достаточно знать значение либо s, либо res, либо st, чтобы вывести значения всех остальных переменных.

Кроме того, явно отметим, что этот подход легко обобщить для поддержки большего количества видов вычислений. Например, можно добавить поддержку SIMD-ускоренных функций, обрабатывающих по 16-32 байта за раз. Однако для простоты изложения мы на это отвлекаться не будем.

Реализация статистик

Какие у нас будут статистики? Давайте реализуем следующие:

• число байт,
• число (UTF-8)-символов,
• число слов,
• максимальная длина строки,
• количество строк.

Или в коде:

data Statistics = Bytes | Chars | Words | MaxLL | Lines deriving (Eq, Ord)

Этого должно быть более чем достаточно для иллюстрации подхода, да и wc других статистик особо не предлагает.

Тогда базовые статистики — это всего лишь реализации класса Statistic. И, так как состояние большинства статистик — одно число, давайте для удобства добавим типизированную обёртку:

newtype Tagged a = Tagged Word64 deriving (Eq, Show, Num)

здесь a предназначен исключительно для того, чтобы отличить Tagged 'Bytes от Tagged 'Chars.

Теперь мы можем написать самую простую статистику: подсчёт количества байт:

instance Statistic 'Bytes (Tagged 'Bytes) (Tagged 'Bytes) 'Chunked where
  initState = 0
  extractState = id
  computation = ChunkedComputation (\st _ -> st + 1) (\st str -> st + fromIntegral (BS.length str))

Это, пожалуй, достаточно самодокументируемый код:

1. Мы говорим, что Bytes обозначает статистику, у которой Tagged 'Bytes является и типом состояния, и типом результата. Кроме того, эта статистика поддерживает чанковые вычисления.
2. Начальное состояние (то есть, количество байт) равно 0.
3. Для того, чтобы получить результат из состояния, не нужно делать ничего особенного — состояние и есть результат.
4. computation обязательно должно быть чанковым вычислением, так как мы сказали 'Chunked на первой строке. Функция шага игнорирует текущий символ и просто увеличивает счётчик, а чанковая функция прибавляет ко счётчику всю длину входа.

Пока что вроде всё просто и понятно.

Остальные статистики реализуются аналогично, и реализации довольно скучны, так что я их спрячу под спойлер, но заинтересованный читатель приглашается

Подсчёт строк тоже довольно прост, и эта статистика тоже поддерживает как побайтовые, так и чанковые вычисления:

instance Statistic 'Lines (Tagged 'Lines) (Tagged 'Lines) 'Chunked where
  initState = 0
  extractState = id
  computation = ChunkedComputation (\st c -> st + if c == 10 then 1 else 0) (\st str -> st + fromIntegral (BS.count 10 str))

Что насчёт подсчёта слов? Здесь мы поддерживаем только побайтовый подсчёт и заимствуем реализацию из предыдущего поста:

data WordsState = WordsState { ws :: Word64, wasSpace :: Word64 }

instance Statistic 'Words (Tagged 'Words) WordsState 'ByteOnly where
  initState = WordsState 0 1
  extractState WordsState { .. } = Tagged (ws + 1 - wasSpace)
  computation = ByteOnlyComputation step
    where
      step WordsState { .. } c = WordsState (ws + (1 - wasSpace) * isSp) isSp
        where
          isSp | c == 32 || c - 9 <= 4 = 1
               | otherwise = 0

Кроме того, это хороший пример статистики с нетривиальной функцией преобразования состояния в результат.

Итак, мы портировали те статистики, что мы уже реализовали ранее. Что насчёт новеньких — подсчёта UTF-8-символов и максимальной длины строки?

Вся сложность подсчёта символов состоит в аккуратном жонглировании битами:

instance Statistic 'Chars (Tagged 'Chars) (Tagged 'Chars) 'ByteOnly where
  initState = 0
  extractState = id
  computation = ByteOnlyComputation $ \cnt c ->
        cnt + 1 - fromIntegral (   ((c .&. 0b10000000) `shiftR` 7)
                               .&. (1 - ((c .&. 0b01000000) `shiftR` 6))
                               )

Здесь мы опираемся на следующее свойство кодировки UTF-8: каждый символ имеет один и только один байт, который не следует паттерну 10xxxxxx. Другими словами, нам не нужно полноценно декодировать UTF-8 только для того, чтобы подсчитать количество символов.

Что насчёт максимальной длины строки? Тут вся сложность в корректном учёте непечатаемых символов и правильной обработке символов табуляции (кстати, тут, как и во всех прочих статистиках кроме предыдущей, мы ограничиваемся ASCII):

instance Statistic 'MaxLL (Tagged 'MaxLL) MaxLLState 'ByteOnly where
  initState = MaxLLState 0 0
  extractState MaxLLState { .. } = Tagged $ max maxLen curLen
  computation = ByteOnlyComputation step
    where
      step MaxLLState { .. } 9 = MaxLLState maxLen $ curLen + 8 - (curLen `rem` 8)
      step MaxLLState { .. } 8 = MaxLLState maxLen $ max 0 (curLen - 1)
      step MaxLLState { .. } c | c == 10
                              || c == 12
                              || c == 13 = MaxLLState (max maxLen curLen) 0
                               | c < 32 = MaxLLState maxLen curLen
      step MaxLLState { .. } _ = MaxLLState maxLen (curLen + 1)

Кстати, эта функция даже корректно обрабатывает backspace, в отличие от wc!

Итак, у нас есть все базовые статистики. Теперь можно перейти к самому интересному: их комбинированию.

Комбинирование статистик

Если a — статистика, и b — статистика, то их пара — тоже статистика, и это наш шаг индукции. Давайте начнём с реализации типа для пары статистик:

infixr 5 :::
data a ::: b = a ::: b deriving (Show)

Мы также могли использовать обычный тип (,), но теперь нам не нужно думать о том, сможет ли компилятор избежать ленивости или нет, да и, на мой взгляд, этот отдельный тип сделает поднятый на уровень типов код более читабельным.

Теперь выразим, как совмещать статистики.

Во-первых, что насчёт комбинирования чанковых и побайтовых статистик? Если обе поддерживают чанковые вычисления, то и результат их поддерживает, иначе придётся ограничиться побайтовым подсчётом. На языке типов это можно выразить так:

type family CombineCompTy a b where
  CombineCompTy 'Chunked 'Chunked = 'Chunked
  CombineCompTy _ _ = 'ByteOnly

Как инстанс класса Statistic выглядит для пары статистик? Можно написать что-то такое:

instance (Statistic sa resa sta compa, Statistic sb resb stb compb)
       => Statistic (sa '::: sb) (resa ::: resb) (sta ::: stb) (CombineCompTy compa compb) where
  initState = initState ::: initState
  extractState (a ::: b) = extractState a ::: extractState b
  computation =
    case (computation :: StatComputation sta compa, computation :: StatComputation stb compb) of
         (ByteOnlyComputation a, ChunkedComputation b _)
            -> ByteOnlyComputation $ combine a b
         (ChunkedComputation a _, ByteOnlyComputation b)
            -> ByteOnlyComputation $ combine a b
         (ByteOnlyComputation a, ByteOnlyComputation b) 
            -> ByteOnlyComputation $ combine a b
         (ChunkedComputation stepA chunkA, ChunkedComputation stepB chunkB)
            -> ChunkedComputation (combine stepA stepB) (combine chunkA chunkB)
    where
      combine fa fb = \(a ::: b) w -> fa a w ::: fb b w

То есть, если sa — статистика с типом результата resa, типом состояния sta и режимом подсчёта compa, и аналогично для sb/resb/stb/compb, то пара sa ::: sb — тоже статистика, причём её тип результата — пара resa ::: resb, тип состояния — пара sta ::: stb, а режим вычисления — результат функции на уровне типов CombineCompTy compa compb.

Заметьте разницу между (с крыжечкой, запромоученным) :::-в-роли-конструктора и (без крыжечки, незапромоученным) :::-в-роли-типа в определении инстанса. sa и sb — термы, запромоученные на уровень типов, поэтому рядом с ними мы используем (запромоученный) конструктор термов, тогда как остальные переменные — типы, так что рядом с ними мы используем (незапромоученный) конструктор типов.

Всё бы хорошо, вот только… мы не можем написать такой инстанс. В текущем хаскеле нельзя использовать семейство типов в таком виде. К счастью, это легко обойти добавлением новой переменной comp вместе с ограничением, что она должна быть равна результату применения этого семейства типов:

instance (Statistic sa resa sta compa,
          Statistic sb resb stb compb,
          comp ~ CombineCompTy compa compb)
       => Statistic (sa '::: sb) (resa ::: resb) (sta ::: stb) comp where

Остальная часть инстанса никак не меняется.

Давайте теперь разбирать термы. Первые два метода просты:

1. Начальное состояние пары статистик равно паре из начальных состояний соответствующих статистик.
2. Чтобы достать ответ из состояния для пары статистик, нужно достать ответы из соответствующих компонент состояния-пары и сделать из них пару.

Кстати, нам тут не нужна ни единая аннотация типов — компилятор может вывести всё сам, и это очень круто!

Третий метод уже поинтереснее и куда более многословен, но он по большому счёту следует за определением CombineCompTy (и тайпчекер это на самом деле проверяет). Опять же, если обе статистики поддерживают чанковые вычисления, то и результирующая статистика их поддерживает (это последний случай), а иначе всё сводится к побайтовому вычислению.

Основная часть бойлерплейта происходит от необходимости явного паттерн-матчинга по хотя бы одному из вычислителей, который, в свою очередь, нужен для того, чтобы тайпчекер мог убедиться, что правая часть каждой ветки case имеет правильный тип.

А какой тип правильный? Согласно определению класса, это StatComputation st comp, где, согласно определению инстанса, comp ~ CombineCompTy compa compb. То есть, ожидаемый тип зависит от конкретных compa и compb. А чтобы вычислить CombineCompTy, тайпчекер должен знать, равны ли Chunked и compa, и compb, или нет.

Откуда тайпчекер знает значение compa или compb? А в общем случае он и не знает. Однако, если мы сматчимся по результату соответствующего computation, то тогда нам поможет логика GADT. Действительно, посмотрим ещё раз на определение типа StatComputation. Если значение этого типа было создано при помощи конструктора ChunkedComputation, то соответствующая comp обязательно должна быть равна Chunked. Если же использовался конструктор ByteOnlyComputation, то соответствующая переменная равна ByteOnly.

Кстати, если бы мы написали CombineCompTy без использования _-паттернов, а перечисляя все четыре возможные комбинации, то тайпчекер должен был бы знать значения и compa, и compb.

Ещё стоит отметить, что такое представление позволяет иметь дубликаты: Words '::: Words соответствует комбинированной статистике, считающей количество слов дважды. Пурис⊤ы на такое бы смотрели неодобрительно, но для наших целей оно вполне подходит, тем более, что чуть позже конкретно эта возможность нам очень пригодится.

Использование статистик

Супер, мы написали кучу кода. Как его использовать?

Пусть нам дан тип, реализующий класс Statistic, и ByteString, по которой надо посчитать статистику. Тогда мы сначала рассмотрим GADT, возвращаемый функцией computation. Если это ChunkedComputation, то мы ему кормим всю входную строку. Иначе это ByteOnlyComputation, и мы делаем BS.foldl'. Или в коде:

wc :: forall s res st comp. Statistic s res st comp => BS.ByteString -> res
wc s = extractState $! runCompute computation
  where
    runCompute :: StatComputation st comp -> st
    runCompute (ByteOnlyComputation step) = BS.foldl' step initState s
    runCompute (ChunkedComputation _ chunker) = chunker initState s

Функциональные зависимости снова нас выручают, так как тайпчекер может вывести все аргументы класса (s, st, comp) по одному лишь желаемому типу результата res. С другой стороны, похоже, тайпчекер не может вывести тип runCompute, так что нам приходится указывать его явно. При этом переменные st и comp в её сигнатуре должны совпадать с переменными в типе wc, а для этого (очень интуитивно) используется forall и расширение ScopedTypeVariables.

Теперь мы можем выбирать конкретные статистики либо через явную аннотацию типа возвращаемого значения:

let result = wc someBS :: Tagged 'Words ::: Tagged 'Lines

либо при помощи расширения TypeApplications и явного указания значения переменной s в сигнатуре функции:

let result = wc @('Words '::: 'Lines) someBS

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

Предварительная оценка производительности

Оправданы ли наши усилия, или же мы занимались всей этой ерундой впустую?

Давайте измерим, сколько времени занимает wc @'Words, используя всю ту же методологию. Наилучшее время выполнения — 1.51 секунд, немногим больше, чем подсчёт одних лишь байт, слов и строк в немодуляризованной версии. Не фонтан, но не так уж плохо.

Насколько хорош компилятор в устранении повторяющихся вычислений? Давайте измерим wc @('Words '::: 'Words)!

Только вот лично у меня здесь начинается полная ерунда. Я бы ожидал, возможно, увидеть чуть большие цифры, в идеале — такие же, но… Оно работает быстрее: 1.34 секунды. А если посчитать wc @('Words '::: 'Words '::: 'Words)? 1.30 секунд. Впрочем, последующее добавление 'Words не помогает.

Что ещё более странно — эти результаты невоспроизводимы у других людей. Я поспрашивал народ в ирке на канале #haskell — у них этот результат не воспроизводился. Время работы было довольно стабильным и не зависящим от числа дубликатов одного и того же вычисления.

У меня этому нет хорошего объяснения. Я помедитировал на GHC Core — безрезультатно, всё выглядит разумным. Если бы это было воспроизводимое улучшение, я бы мог потеоретизировать о поведении инлайнера, или специализатора, или о чём-то таком. Но учитывая, что эти результаты не воспроизводятся у других людей… Страннота-ерунда. Я не понимаю, почему код так себя ведёт, и не могу сказать, что мне это нравится.

Ладно, хватит ныть, давайте ещё поизмеряем. Что насчёт всех трёх статистик, которые у нас были раньше? Измерим wc @('Bytes '::: 'Words '::: 'Lines)! Время работы в этом случае — 1.53 секунды. Это немногим хуже 1.45 секунд, которые у нас были раньше, но, на мой взгляд, вполне терпимо.

Итак, мы эмпирически доказали, что у этого подхода хотя бы есть шанс. Давайте теперь посмотрим, какие плоды нам даёт такая модуляризация.

Тестирование

Тестировать такой код — одно удовольствие! Локальность рассуждений позволяет протестировать каждую статистику в отдельности и при этом даёт уверенность, что они работают корректно в любой комбинации.

Например, мы можем проверить, что для любой строки количество слов равно длине списка, возвращаемого стандартной функцией words, если проигнорировать все символы с кодом выше 127. В частности, мы можем считать это определяющим свойством нашей статистики подсчёта слов, но это уже скорее вопрос философских взглядов.

В коде это выражается как набор QuickCheck-свойств, записанных и для ASCII, и для UTF-8-входов:

import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-- ещё скучные импорты

import Data.WordCount

wrapUnicode :: UnicodeString -> (BS.ByteString, T.Text)
wrapUnicode ustr = (T.encodeUtf8 txt, txt)
  where
    txt = T.pack $ getUnicodeString ustr

replaceNonAsciiSpaces :: Char -> Char
replaceNonAsciiSpaces ch | ch >= chr 127 && isSpace ch = '_'
                         | otherwise = ch

main :: IO ()
main = hspec $ parallel $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 1000) $ do
  describe "ASCII support" $ do
    it "Counts bytes correctly" $ property $
      \(getASCIIString -> str) -> wc @'Bytes (BS.pack str) `shouldBe` genericLength str
    it "Counts chars correctly" $ property $
      \(getASCIIString -> str) -> wc @'Chars (BS.pack str) `shouldBe` genericLength str
    it "Counts words correctly" $ property $
      \(getASCIIString -> str) -> wc @'Words (BS.pack str) `shouldBe` genericLength (words str)
    it "Counts lines correctly" $ property $
      \(getASCIIString -> str) -> wc @'Lines (BS.pack str) `shouldBe` genericLength (filter (== '\n') str)
  describe "UTF8 support" $ do
    it "Counts bytes correctly" $ property $
      \(wrapUnicode -> (bs, _))   -> wc @'Bytes bs `shouldBe` fromIntegral (BS.length bs)
    it "Counts chars correctly" $ property $
      \(wrapUnicode -> (bs, txt)) -> wc @'Chars bs `shouldBe` fromIntegral (T.length txt)
    it "Counts words correctly" $ property $
      \(wrapUnicode -> (bs, txt)) -> wc @'Words bs `shouldBe` genericLength (T.words $ T.map replaceNonAsciiSpaces txt)
    it "Counts lines correctly" $ property $
      \(wrapUnicode -> (bs, txt)) -> wc @'Lines bs `shouldBe` fromIntegral (T.count "\n" txt)

И всё!

Заметим несколько вещей:

• В более выразительном языке мы могли бы сформулировать эти свойства как полноценные теоремы и вполне могли бы их доказать внутри языка, что даёт куда большую уверенность в корректности, чем несколько тысяч случайно сгенерированных примеров. В самом деле, кое-какой баг в реализации функции подсчёта количества UTF-8-символов в среднем ловился только на входе из второй или третьей тысячи примеров.
• Мы не формулируем и не проверяем никакие свойства для функции подсчёта длины строк, так как это… нетривиально.
• Тесты исполняются достаточно быстро: прогнать их все на 10 тысячах примеров (для каждого свойства) длиной до тысячи символов занимает 3-5 секунд на моей машине (с учётом создания тестовых данных).

В любом случае, читателю предлагается реализовать что-то подобное для версии на C из GNU Coreutils.

Обработка опций командной строки

Воспользуемся библиотекой optparse-applicative. Определим тип, хранящий опции командной строки, и парсер для него:

data Options = Options
  { countBytes :: Bool
  , countChars :: Bool
  , countLines :: Bool
  , countMaxLineLength :: Bool
  , countWords :: Bool
  , files :: [FilePath]
  }

options :: Parser Options
options = Options
  <$> switch (long "bytes" <> short 'c' <> help "print the byte counts")
  <*> switch (long "chars" <> short 'm' <> help "print the character counts")
  <*> switch (long "lines" <> short 'l' <> help "print the newline counts")
  <*> switch (long "max-line-length" <> short 'L' <> help "print the maximum display width")
  <*> switch (long "words" <> short 'w' <> help "print the word counts")
  <*> some (argument str (metavar "FILES..."))

Модифицируем наш main, чтобы распарсить командную строку и отобразить опции на значения типа Statistics, подсчитывая байты, слова и строки по умолчанию:

main :: IO ()
main = do
  Options { .. } <- execParser $ info (options <**> helper) (fullDesc <> progDesc "Print newline, word, and byte counts for each file")
  let selectedStats = map snd $ filter fst [ (countBytes, Bytes), (countChars, Chars)
                                           , (countWords, Words), (countMaxLineLength, MaxLL)
                                           , (countLines, Lines)
                                           ]
  let stats | null selectedStats = [Bytes, Words, Lines]
            | otherwise = selectedStats

Всё это наверняка можно сделать ещё элегантнее, но цель статьи не в описании парсинга командной строки, так что нам бы уж хоть как-нибудь получить список опций.

Итак, список опций мы получили. Что мы делаем дальше? Нам нужно сконвертировать этот список в тип, который мы можем скормить wc. Другими словами, у нас есть терм, и нам из него нужно сделать тип. Звучит прямо как зависимые типы!

Почти зависимые типы

Этот подход обречён с точки зрения производительности по причинам, которые будут понятны позднее, но давайте всё равно его попробуем, ведь так мы сможем посмотреть, как писать что-то околозависимотипизированное в современном хаскеле, а зависимые типы — это круто!

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

Мы не знаем, какие статистики мы будем считать во время выполнения, поэтому мы заворачиваем их в экзистенциальный тип:

data SomeStats where
  MkSomeStats :: Statistic s res st comp => proxy s -> SomeStats

Здесь proxy s — свидетель конкретного инстанса Statistic. Его единственная задача — обеспечить нас конкретным типом статистики.

Пусть теперь у нас есть значение этого экзистенциального типа. Как мы можем им пользоваться? Можно попробовать что-то такое:

wc' :: SomeStats -> BS.ByteString -> ?
wc' (MkSomeStats (_ :: proxy s)) input = wc @s input

но… Что мы должны написать вместо ?? Какой возвращаемый тип этой функции? Понятно, что это res из соответствующего инстанса Statistic, но у нас его здесь нет.

Может, попробовать написать как-то так?

data SomeStats where
  MkSomeStats :: Statistic s res st comp => proxy1 s -> proxy2 res -> SomeStats

wc' :: SomeStats -> BS.ByteString -> res
wc' (MkSomeStats (_ :: proxy1 s) (_ :: proxy2 res)) input = wc @s input

Но на самом деле понятно, что это работать не будет: в точке определения типа wc' нам ещё никакой res, завёрнутый внутрь SomeStats, не доступен.

Что же делать?

Давайте сделаем шаг назад и подумаем. Мы действительно не знаем конкретный возвращаемый тип wc, но нам это и не нужно! Достаточно того, что его можно показать пользователю. Иными словами, нам важно только то, что мы можем, например, преобразовать его в строку при помощи show, для чего достаточно добавить констрейнт, что res реализует Show:

data SomeStats where
  MkSomeStats :: (Statistic s res st comp, Show res) => proxy s -> SomeStats

Тогда wc будет выглядеть примерно так:

wc' :: SomeStats -> BS.ByteString -> String
wc' (MkSomeStats (_ :: proxy s)) input = show $ wc @s input

и это корректно типизированный код.

Хорошо, но как теперь преобразовать наш список stats в SomeStats? Давайте начнём с промоутинга базовых статистик:

promoteStat :: Statistics -> SomeStats
promoteStat Bytes = MkSomeStats (Proxy :: Proxy 'Bytes)
promoteStat Chars = MkSomeStats (Proxy :: Proxy 'Chars)
promoteStat Words = MkSomeStats (Proxy :: Proxy 'Words)
promoteStat MaxLL = MkSomeStats (Proxy :: Proxy 'MaxLL)
promoteStat Lines = MkSomeStats (Proxy :: Proxy 'Lines)

Довольно уродливо, да и грустно, что нужно вручную перечислить все значения типа Statistics, но таково ограничение системы типов хаскеля. Вот тебе и эрзац-зависимые типы: несмотря на то, что терм Bytes и (запромоученный) тип 'Bytes выглядят одинаково, тайпчекер их считает совершенно разными сущностями без всякой связи между ними, и нам приходится устанавливать эту связь вручную.

В любом случае, с этим нашим promoteStat теперь можно пройтись и по всему списку целиком:

promoteStats :: [Statistics] -> SomeStats
promoteStats [s] = promoteStat s
promoteStats (s:ss) =
  case (promoteStat s, promoteStats ss) of
       (MkSomeStats (_ :: proxy1 st), MkSomeStats (_ :: proxy2 sst))
                                   -> MkSomeStats (Proxy :: Proxy (st '::: sst))

Для списка, состоящего из одного элемента, мы просто используем функцию promoteStat.

Если же список состоит из двух и более элементов, то всё куда интереснее. Сначала всё относительно стандартно для рекурсивных функций: голову мы промоутим при помощи того же promoteStat, а хвост обрабатываем рекурсивным вызовом promoteStats. Дальше их надо как-то совместить, и здесь начинается лёгкая магия. Мы матчимся по результатам вызовов promoteStat и promoteStats, привязывая переменную типа st к типу, соответствующему голове списка, а sst — к типу, соответствующему хвосту.

Мы ничего не знаем об этих типах кроме того, что они реализуют класс Statistic (так как это требуется констрейнтом в соответствующем конструкторе экзистенциального типа). Но если они реализуют Statistic, то и st ::: sst реализует Statistic как раз из-за комбинирующего инстанса, который мы написали выше! Кроме того, мы знаем, что rest и resst (некоторые воображаемые безымянные переменные типов, соответствующие результатам статистик st и sst) реализуют Show. Поэтому можно вывести, что rest ::: resst также реализует Show, а это ровным счётом тип результата статистики st ::: sst!

Короче, в итоге получается, что выражение MkSomeStats (Proxy :: Proxy (st '::: sst)) вполне корректно типизировано. И очень круто, что тайпчекер может это всё сам вывести!

Кстати, это не тотальная функция: мы не обрабатываем случай пустого списка опций. С другой стороны, он у нас никогда и не возникнет, а использование вещей вроде NonEmpty усложнит изложение без всякой видимой выгоды.

Как бы там ни было, пользоваться этой функцией легко:

main :: IO ()
main = do
  -- obtaining `stats` as before
  forM_ files $ \path -> do
    contents <- unsafeMMapFile path
    putStrLn $ wc' (promoteStats stats) contents

Чудеса производительности

Насколько (не)эффективен этот подход?

Если посчитать только строки, то мы получим многообещающие 1.05 секунд — ровно столько же, сколько занимает BS.count 10.

Но это чанковая статистика, обрабатывающая весь вход за раз. Как насчёт побайтовых статистик, например, числа слов? Запускам, получаем… 14 секунд вместо полутора.

Чёрт, 14 секунд.

И, кстати, оно жуёт память как бешеное:

  74,873,139,008 bytes allocated in the heap

Я не проводил систематических замеров аллокаций для прошлых версий, но это число всегда было меньше мегабайта. Ну, хотя бы эта версия всё ещё $$ по памяти — большинство аллокаций почти сразу умирают в нулевом поколении GC (60,512 bytes maximum residency).

Ладно. Что, если мы посчитаем и слова, и строки? 27 секунд, 120 гигабайт аллоцировано.

Что насчёт слов, строк и байт? Можете угадать?

Если вы сказали «42 секунды», то можете съесть пирожок: оно выполняется 41 секунду и аллоцирует 194 гигабайта. Ну, максимальное потребление памяти согласно RTS хотя бы всё ещё в районе 60 килобайт.

Почему всё так плохо?

Ну, когда мы пишем такую функцию:

wc' (MkSomeStats (_ :: proxy s)) input = show $ wc @s input

тогда компилятор никак не может знать, какой computation связан с данной конкретной s — это исключительно рантайм-свойство, известное только после того, как пользователь сделает свой выбор. Поэтому у компилятора нет другого выхода, кроме как скомпилировать это в прямую передачу словаря методов класса Statistic и вызова методов этого словаря по указателю без какого бы то ни было инлайнинга.

Так что конкретно здесь происходит?

Функция wc' получает указатель на функцию computation, обёрнутый в значение экзистенциального типа SomeStats и передаёт этот указатель дальше функции wc, которая вызывает функцию по этому указателю для каждого входного байта. Никакого инлайнинга, никаких связанных с этим оптимизаций, никаких горячих циклов, а вместо этого всего вызов функции на каждой итерации. То есть, это примерно 1.8 миллиардов вызовов — конечно же это будет медленно!

При этом вызывающая сторона ответственна за упаковку всех нужных указателей в экзистенциальный тип при помощи функции promoteStats. Как именно она это делает?

Например, если stats состоит из единственного элемента, то используется уравнение

promoteStats [s] = promoteStat s

и если s оказывается, например, Words, то promoteStat вычисляется согласно уравнению

promoteStat Words = MkSomeStats (Proxy :: Proxy 'Words)

В итоге promoteStats заворачивает в SomeStats указатели на методы, соответствующие реализации Statistic для Words.

Но это простой случай. Что происходит, если в дело вступает второе уравнение?

promoteStats (s:ss) =
  case (promoteStat s, promoteStats ss) of
         (MkSomeStats (_ :: proxy1 st), MkSomeStats (_ :: proxy2 sst)) -> MkSomeStats (Proxy :: Proxy (st '::: sst))

Тогда указатель на фукнцию computation строится примерно следующим образом: case в правой части уравнения извлекает указатели из того, что вернули promoteStat и рекурсивный вызов promoteStats, и, если упрощать, передаёт их функции computation реализации Statistic для «индуктивного» случая sa ::: sb, которая, в свою очередь, вызывает функции по этим указателям один за другим.

Поэтому если список опций состоит из двух статистик, мы платим оверхед в 13-14 секунд дважды, и общее время выполнения должно быть в районе 28 секунд — ровно как мы и наблюдали. А если бы мы выбрали все пять статистик, то время работы было бы 65-70 секунд.

Так что понимание того, как работают экзистенциальные типы (да и вообще стирание типов) позволяет заранее ожидать исключительно хреновую производительность такого подхода.

Кстати, мы заодно можем оценить стоимость вызова функции. Оверхед составляет 13 секунд (14 секунд на всё минус 1 секунда на бизнес-логику) на 1.8 миллиардов вызовов — то есть, примерно 7 наносекунд на вызов. Звучит разумно.

Уродливый подход

Однако это упражнение с экзистенциальными типами позволяет нам ограничить пространство возможных решений: мы хотим убедиться, что компилятор видит точный (мономорфизированный) тип wc в каждой точке вызова. В идеале у нас бы было что-то вроде

main = do
  -- ..
  case stats of
       [Words] -> print $ wc @'Words contents
       [Bytes] -> print $ wc @'Bytes contents
       [Lines] -> print $ wc @'Lines contents
       [Words, Bytes] -> print $ wc @('Words '::: 'Bytes) contents
       [Lines, Bytes] -> print $ wc @('Lines '::: 'Bytes) contents
       -- ...

и так далее. Но даже если у нас всего лишь пять возможных статистик, то школьная комбинаторика говорит нам, что у нас будет $$ ветка в case. Понятно, что писать их все — не выход.

Вот только компилятор может нам помочь их написать, для чего нам придётся прибегнуть к Template Haskell. Мы напишем (мета-)функцию dispatch, которая будет использоваться так:

  contents <- unsafeMMapFile path
  putStrLn $ $(dispatch 'wc 'contents) stats

Здесь $(dispatch 'wc 'contents) создаёт функцию, которая делает case-анализ stats примерно так же, как приведённый чуть выше пример.

Написание dispatch — довольно техническое упражнение в Template Haskell, поэтому я просто покажу, что в итоге получается:

dispatch :: Name -> Name -> Q Exp
dispatch fun bs = reify ''Statistics >>= \case
  TyConI (DataD _ _ _ _ cons _) -> do
    let consNames = [ name | NormalC name _ <- cons ]
    let powerset = filterM (const [True, False]) consNames
    let matches = buildMatch fun bs <$> filter (not . null) powerset
    fallbackMatch <- (\body -> Match WildP (NormalB body) []) <$> [e| error "Unexpected input" |]
    pure $ LamCaseE $ matches <> [fallbackMatch]
  _ -> fail "unsupported type"

buildMatch :: Name -> Name -> [Name] -> Match
buildMatch fun bs consNames = Match (ListP $ (`ConP` []) <$> consNames) (NormalB $ VarE 'show `AppE` (wcCall `AppE` VarE bs)) []
  where
    wcCall = VarE fun `AppTypeE` foldr1 f (PromotedT <$> consNames)
    f accTy promotedTy = PromotedT '(:::) `AppT` accTy `AppT` promotedTy

Если совсем вкратце, то мы узнаём все конструкторы типа Statistics (поэтому, кстати, добавить новые статистики будет очень легко), и для каждого непустого подмножества множества конструкторов (то есть, для каждого непустого элемента в powerset) мы строим отдельную case-ветку при помощи buildMatch. Все построенные ветки мы заворачиваем в один большой лямбда-case (с расширением {-# LANGUAGE LambdaCase #-}).

Кстати, довольно забавно, что тут мы можем немного подзабить на корректную обработку ошибок и тотальность функций, так как всё равно этот код будет выполняться во время компиляции, и все возможные ошибки вылезут тогда же.

Единственная вещь, которая немного меня коробит (ну, кроме использования TH) — получаемая функция ожидает, что массив stats будет отсортированным. Можно оправдать это ожидание двумя способами. С одной стороны, мы можем аккуратно выбрать порядок элементов в списке

  let selectedStats = map snd $ filter fst [ (countBytes, Bytes), (countChars, Chars)
                                           , (countWords, Words), (countMaxLineLength, MaxLL)
                                           , (countLines, Lines)
                                           ]

согласно порядку, порождаемому сгенерированной компилятором реализацией Ord. С другой стороны, мы можем просто явно сортировать список stats. Оба подхода вполне работают, однако второй чуть чище и надёжнее, а потери в производительности из-за сортировки stats, очевидно, пренебрежимо малы.

Давайте теперь сложим все кусочки вместе!

main :: IO ()
main = do
  Options { .. } <- execParser $ info (options <**> helper) (fullDesc <> progDesc "Print newline, word, and byte counts for each file")
  let selectedStats = map snd $ filter fst [ (countBytes, Bytes), (countChars, Chars)
                                           , (countWords, Words), (countMaxLineLength, MaxLL)
                                           , (countLines, Lines)
                                           ]
  let stats | null selectedStats = [Bytes, Words, Lines]
            | otherwise = selectedStats
  forM_ files $ \path -> do
    contents <- unsafeMMapFile path
    putStrLn $ $(dispatch 'wc 'contents) stats

Окончательная производительность

Насколько хорошо работает этот подход? Я не буду проверять все комбинации параметров (31 вариант — слишком много), поэтому выберу какое-то случайное их подмножество. Кроме того, в этот раз я снова возьму wc из GNU Coreutils в качестве некоторой базовой точки, чтобы привязать эти измерения хоть к чему-то. Бенчмаркинг производится так же, как и всегда: каждый тест запускается 5 раз на тестовом файле в 1.8 гигабайт, и рассматривается минимальное время в юзерспейсе. wc из Coreutils запускается с переменными окружения LC_ALL=C LANG=C, если не указано иное.

Вот результаты:

Некоторые наблюдения и замечания:

• Мне всё ещё рвёт шаблон, что подсчёт байт и слов быстрее, чем подсчёт одних лишь слов.
• Похоже, что версия на C всегда считает некоторый базовый набор статистик (слова, байты, строки и максимальную длину строк) если включён либо подсчёт строк, либо подсчёт максимальной длины. Я не удивлён.
• ¹ Да, time буквально показывает 0.00user для обоих программ в случае подсчёта байт.
• ² Первое число для подсчёта байт и строк (1.06 секунд) — результат с апстримовой библиотекой bytestring. Второе число — с пропатченной bytestring, где функция подсчёта количества вхождений символа (count) оптимизирована с использованием SIMD-интринсиков. По иронии судьбы оригинальная count реализована на C, и, что снова иронично, комплиятор не может её оптимизировать достаточно хорошо, и даже чистая реализация на хаскеле была бы быстрее (хотя и не настолько быстро, как с ручными оптимизациями и SIMD), но всю эту иронию лучше оставить для другого поста.
• ³ Здесь wc запускается с UTF-8-локалью, так как иначе он понимает, что число символов равно числу байт, и работает за константное время, тогда как мы хотим измерить скорость подсчёта UTF-8-символов.

На мой взгляд, вполне себе неплохие результаты.

Всякие мелочи

Наша программа может обрабатывать опции командной строки, она поддерживает те же статистики, что и wc, она может обрабатывать несколько файлов. Что ещё можно добавить?

Параллелизм

Это легко: мы просто заменяем forM_ на forConcurrently_ из библиотеки async:

main :: IO ()
main = do
  Options { .. } <- execParser $ info (options <**> helper) (fullDesc <> progDesc "Print newline, word, and byte counts for each file")
  let selectedStats = map snd $ filter fst [ (countBytes, Bytes), (countChars, Chars)
                                           , (countWords, Words), (countMaxLineLength, MaxLL)
                                           , (countLines, Lines)
                                           ]
  let stats | null selectedStats = [Bytes, Words, Lines]
            | otherwise = selectedStats
  forConcurrently_ files $ \path -> do
    contents <- unsafeMMapFile path
    putStrLn $ $(dispatch 'wc 'contents) stats

Теперь программа будет обрабатывать одновременно столько же файлов, сколько у нас есть ядер (вернее, сколько ядер разрешили использовать хаскелевскому RTS, что по умолчанию равно полному числу ядер). Если бы нас это не устраивало, то можно было бы добавить ещё одну опцию типа -j, но это не так уж сложно и предлагается в качестве упражнения читателю.

Каков оверхед этого параллелизма?

Подсчёт слов и байт в одном тестовом файле займёт 1.22 секунд — почти как последовательная версия, хоть и дисперсия значений в этом случае будет повыше.

Если же мы запустим эту программу, скормив ей наш тестовый файл шесть раз (по числу физических ядер в моей машине), то время работы будет равно 1.47 секунд, но с ещё более существенной дисперсией. Думаю, что в этом случае всё упирается в шину данных.

Красивая печать

Если мы сейчас запустим нашу программу, то она распечатает результат в виде

Tagged 123 ::: (Tagged 456 ::: Tagged 789)

Это не очень дружественно к пользователю, так что давайте это исправим! Проще всего добавить специальный метод в класс Statistic:

class Statistic s res st comp | res -> s, st -> s
                              , s -> res, s -> st, s -> comp where
  -- ...
  prettyPrint :: res -> String

Его реализация для базовых статистик проста, например:

instance Statistic 'Bytes (Tagged 'Bytes) (Tagged 'Bytes) 'Chunked where
  -- ...
  prettyPrint (Tagged n) = show n <> " bytes"

Для комбинации статистик тоже ничего сложного, просто чуть больше писанины:

  prettyPrint (a ::: b) = prettyPrint a <> "\n" <> prettyPrint b

Мы также должны обновить нашу функцию buildMatch, чтобы она использовала prettyPrint вместо show:

buildMatch fun bs consNames = Match (ListP $ (`ConP` []) <$> consNames) (NormalB $ VarE 'prettyPrint `AppE` (wcCall `AppE` VarE bs)) []

И всё!

Больше видов входных данных

Пока что наша реализация предполагает, что входной файл всегда можно mmapнуть. Однако, так происходит не всегда: например, наша реализация сломается в случае hwc <(cat foo | grep bar).

Это можно исправить, проверяя, является ли путь обычным файлом или символьной ссылкой — их-то mmapить можно. Мы будем осторожны и не будем даже пытаться mmapить все остальные виды путей. Вместо этого мы будем их считывать в ленивую ByteString, чтобы пространственная сложность всё ещё была константной. А ленивая ByteString — это практически список строгих чанков, так что мы можем по ним просто свернуться в случае чанковых вычислений:

import qualified Data.ByteString.Lazy as BSL

wcLazy :: forall s res st comp. Statistic s res st comp => BSL.ByteString -> res
wcLazy s = extractState $! runCompute computation
  where
    runCompute :: StatComputation st comp -> st
    runCompute (ByteOnlyComputation step) = BSL.foldl' step initState s
    runCompute (ChunkedComputation _ chunker) = BSL.foldlChunks chunker initState s

Теперь мы можем модифицировать наш main:

  forConcurrently_ files $ \path -> do
    stat <- getFileStatus path
    if isRegularFile stat || isSymbolicLink stat
      then countStrict stats $ unsafeMMapFile path
      else countLazy stats $ BSL.readFile path

где мы добавили две маленьких вспомогательных функции:

  where
    countStrict stats act = do
      contents <- act
      putStrLn $ $(dispatch 'wc 'contents) stats
    countLazy stats act = do
      contents <- act
      putStrLn $ $(dispatch 'wcLazy 'contents) stats

И всё!

Заметим, что на самом деле вместо добавления функции wcLazy мы могли бы создать ещё один тайпкласс, описывающий тип входной строки, но так как их предполагается всего две и больше не будет, то пользы от этого мало.

Поддержка stdin

Ещё одна вещь, которую умеет Coreutils wc, но не умеет наша версия — поддержка stdin. Исправить это просто, добавив проверку в конец main:

main = do
  -- ... as before ...

  when (null files) $ countLazy stats BSL.getContents

Теперь можно делать что-то вроде

cat testfile.txt | /usr/bin/time hwc-exe -cw

Насколько хуже такой подход с точки зрения производительности? Ну, например, вышеприведённая команда выполняется за 1.40 секунд — то есть, разница с 1.22 секундами ранее вполне себе заметна.

Время компиляции и распухание кода

Здесь я действительно придираюсь, но давайте это тоже упомянем ради какой-никакой объективности: каков оверхед всего этого метапрограммирования? Мы можем говорить либо о времени компиляции, либо о размере получающегося файла, так что давайте рассмотрим обе эти метрики!

Если мы пойдём по «зависимо типизированной» дороге (которую можно считать чем-то вроде базы в этом случае), то stack build займёт 7.9 секунд для всего проекта, и размер результирующего бинарника окажется равен 2.24 мегабайта (после strip).

Подход с Template Haskell компилируется ровно втрое дольше: 23 секунды. С другой стороны, бинарник и не распух толком (особенно учитывая 31 вариант вызова функции): его размер стал 2.34 мегабайта, разница — 4.3%.

Хотя… Во время обычной разработки никто не делает stack build (так как это сборка с оптимизациями). stack build --fast может оказаться куда быстрее.

«Зависимо типизированная» реализация компилируется за 5.6 секунд с --fast, тогда как версия с TH собирается за… 7.8 секунд. Тут уже разница не такая уж и большая. С этим можно жить.

И я знаю, что для части разработчиков это очень важный фактор, так что давайте сравним время компиляции в релизном режиме и размер бинарника с C. Как и ожидалось, хаскель здесь сливает подчистую: на моей машине wc из GNU Coreutils компилируется за 0.06 секунд, и результирующий размер бинарника — 21 килобайт. Бинарник wc с убунты занимает 24 килобайта. В 100 раз меньше, чем хаскель!

Ну, другие мелочи и придирки мне в голову не пришли, так что давайте закругляться и переходить к заключению.

Заключение

Что у нас получилось? Если вкратце, то мы привели наш исходный прототип wc к виду, который куда больше напоминает стандартные Unix-утилиты, и теперь наш хаскель-wc готов для того, чтобы использоваться вместо GNU Coreutils wc. Самое главное — он поддерживает пользовательские опции (и больше разных статистик!), да так, что он считает лишь то, что пользователю на самом деле нужно посчитать, при этом с околонулевым оверхедом на модуляризацию. Забавно, что в каком-то смысле у нас довольно легко получилось куда ближе следовать принципу «не платить за то, что не используешь», так милому сердцам программистов на C и C++, чем в случае реализации на C.

Если более подробно, то мы:

1. разделили наш изначальный прототип wc на набор маленьких, изолированных, тестируемых и композабельных кусочков, по одному на статистику;
2. научились совмещать эти кусочки вместе;
3. написали тесты для статистик по отдельности, будучи уверенными, что вместе они тоже будут работать правильно в любых комбинациях по построению;
4. попытались считать только то, что выбрал пользователь, используя техники, вдохновлённые зависимыми типами, и полюбовались, как красочно и громко эти техники сливают с точки зрения производительности в случае хаскеля;
5. преодолели все проблемы с производительностью обработки опций командной строки при помощи Template Haskell;
6. проверили, что результат весьма близок с точки зрения производительности к нашей изначальной реализации, так что вся эта модульность не имеет существенного влияния на производительность;
7. реализовали несколько других мелких фич, от параллельной обработки файлов до поддержки стандартного входа.

Такие дела.

А, ну и стоит упомянуть ещё две вещи:

1. Наш подход с полузависимыми типами не обязательно нежизнеспособен. Мы могли бы, например, вызывать каждый обработчик не на каждый байт, а на каждые 16-32 килобайта (по размеру кэша L1). Нетрудно подсчитать, что для стоимости вызова функций в 7 наносекунд, времени работы в районе секунды и размере файла в 1.8 гигабайт это дало бы оверхед в 0.4 мс, или 0.04%. Но тогда бы нам не пришлось играться с Template Haskell!
2. Наша реализация всё равно не является полным эквивалентом wc, кое-что она делает по-другому. Например, статистика подсчёта символов не поддерживает кодировки, отличные от UTF-8 или ASCII, тогда как wc работает с произвольной локалью, делегируя всю работу по обработке символов glibc. Но так как наша реализация позволяет очень легко добавлять новые статистики, довольно просто добавить поддержку чего-то подобного, и, что самое главное — это не повлияет на, скажем, подсчёт количества строк или слов. Но про «не платить за то, что не используешь» я уже писал чуть выше.