依云's Blog

Haskell 程序一向编译起来费力，得先下个巨大的 GHC，然后从 Hackage 上下一堆包然后慢慢编译。所以我在这里把自己用的程序放出来。Arch Linux 的 Haskell 程序打包太复杂了，所以不打包了。连二进制包也懒得打。

这两个程序是 shellcheck 和 cgrep。

shellcheck 是一个 bash / POSIX sh 脚本 lint 工具。就是指出程序源码中可能出错的地方，相当于 jshint 之于 JavaScript、pylint 之于 Python（但是不含风格检查）、gcc / clang 的警告之于 C。

cgrep 就是 context-aware grep，比如搜索注释或者字符串里的东西之类的。支持解析几种编程语言。

程序是在 Arch Linux 上编译的，但其它 Linux 也许也可以使用。

下载地址：shellcheck-0.3.7.xz, cgrep-6.4.12.xz.

>>> sha1sum cgrep-6.4.12.xz shellcheck-0.3.7.xz
0588ee29a1a17c1cddc816a8193d8494db7c03cf  cgrep-6.4.12.xz
376b58d485603a7622f83f095a30bddc1da34376  shellcheck-0.3.7.xz

突然想给 locate 命令写个 wrapper，把输出中的家目录和一些因加密而引入的软链接显示为~。自然，这需要读取 locate 命令的输出。在 process 这个库中看到了readProcess函数，似乎是自己想要的（完整代码）：

readLocate :: [String] -> IO String
readLocate args = getArgs >>= \cmd ->
  let args' = args ++ cmd
  in readProcess "locate" args' ""

结果却发现，原本 locate 命令是边查找边输出的，现在变成了先静默，然后一下子全部吐出来。没有按 Haskell 惯常的「懒惰」脾气来。这样一来，当我发现输出项目太多想按Ctrl-C中断时已经晚了。

Google 了一下，找到这个：

I guess people who want laziness can implement it themselves directly, taking care to get whatever laziness it is that they want.

好吧。我先下回 process 库的源码看看readProcess为什么不是惰性的：

readProcess 
    :: FilePath                 -- ^ command to run
    -> [String]                 -- ^ any arguments
    -> String                   -- ^ standard input
    -> IO String                -- ^ stdout
readProcess cmd args input = do
    (Just inh, Just outh, _, pid) <-
        createProcess (proc cmd args){ std_in  = CreatePipe,
                                       std_out = CreatePipe,
                                       std_err = Inherit }

    -- fork off a thread to start consuming the output
    output  <- hGetContents outh
    outMVar <- newEmptyMVar
    _ <- forkIO $ C.evaluate (length output) >> putMVar outMVar ()

    -- now write and flush any input
    when (not (null input)) $ do hPutStr inh input; hFlush inh
    hClose inh -- done with stdin

    -- wait on the output
    takeMVar outMVar
    hClose outh

    -- wait on the process
    ex <- waitForProcess pid

    case ex of
     ExitSuccess   -> return output
     ExitFailure r -> 
      ioError (mkIOError OtherError ("readProcess: " ++ cmd ++ 
                                     ' ':unwords (map show args) ++ 
                                     " (exit " ++ show r ++ ")")
                                 Nothing Nothing)

原来是另开了一 IO 线程读输出，然后等待进程结束后关闭管道。这解释为什么它不是惰性的——它得进程善后处理。

那好吧，改用createProcess好了：

doLocate :: IO (String, ProcessHandle)
doLocate = do
  argv0 <- getProgName
  let args = case argv0 of
                  "lre" -> ["-b", "--regex"]
                  _ -> []
  args' <- getArgs
  let args'' = args ++ args'
  (_, Just out, _, p) <- createProcess (proc "locate" args''){ std_in = Inherit,
                                                               std_out = CreatePipe,
                                                               std_err = Inherit }
  hSetBuffering out LineBuffering
  (,) <$> hGetContents out <*> return p

改进后的程序，不会等待进程结束，而是返回输出和进程句柄。进程句柄用来等待子进程结束，同时获取退出状态。至于那个管道就不关闭了，留给操作系统解决好了。

main = do
  (out, p) <- doLocate
  putStr $ transform out
  waitForProcess p >>= exitWith

改进版的完整程序在此。

既然来学 Haskell 了，Parsec 不应该错过。lrc 文件的格式大家应该都清楚。虽然说它用正则表达式解析很容易也很可靠，但是，我这不是练习么！

数据类型的定义

首先，我们想想歌词文件解析出来有些什么。主要数据当然是一条条带时间的歌词！除此之外，还会可选地有歌名啦歌手啦之类的东西。

先来定义一条歌词，也就是一个最高精确到百分之一秒的时间，和一个字符串。也就是：

data LrcLine = LrcLine {
  time :: Int,
  line :: String
} deriving (Eq, Show, Ord)

我们需要实现Ord类型类以便比较，因为 lrc 文件的歌词有一种紧凑的格式，在相同的歌词前有多个时间。这时，歌词就不是排好序的了。GHC 会自动推断出比较函数，也就是逐个域地进行比较。也可以手动定义其为Ord的实例：

-- import Data.Function (on)
instance Ord LrcLine where
  compare = compare `on` time

然后是整个歌词文件的信息：

data Lrc = Lrc {
  title :: Maybe String,
  artist :: Maybe String,
  album :: Maybe String,
  by :: Maybe String,
  metadata :: [(String, String)],
  lyrics :: [LrcLine]
}

因为可能会有未知的元信息，所以我们定义了一个metadata域来存储之。其类型为[(String, String)]，以便使用lookup函数进行查询。

自顶向下设计解析器：顶层解析器

据RWH的说明，似乎一般都不写解析器的类型签名。但既然是初学嘛，我还是写上好了——

lrcParser :: GenParser Char st Lrc

什么意思我还不太懂，不过最后那个Lrc很显然就是解析结果的类型啦。

我们的解析器先从歌词源文件中读取若干行的元信息，接下来读取所有的歌词数据，最后构造个 Lrc类型的数据。

lrcParser = do
  metadata <- many $ try lrcMeta
  ly <- concat <$> many lrcLine
  return Lrc {
    title = lookup "ti" metadata,
    artist = lookup "ar" metadata,
    album = lookup "al" metadata,
    by = lookup "by" metadata,
    metadata = metadata,
    lyrics = sort ly
  }

many和try都是 Parsec 里的函数。many接受一个类型为解析器的参数，在求值时它一直调用这个解析器，直到它不消耗输入为止。如果这个解析器消耗了输入却又没能成功，那么整个many解析器也就失败了。而try在消耗了任意数量的输入但没有最终成功时会把已消耗的输入退回去，结果是没有消耗输入。开个 GHCi 会话演示下：

>>> ghci
GHCi, version 7.0.3: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
Loading package ffi-1.0 ... linking ... done.
ghci> import Text.ParserCombinators.Parsec
ghci> let p = string "ab" :: GenParser Char st String
Loading package transformers-0.2.2.0 ... linking ... done.
Loading package mtl-2.0.1.0 ... linking ... done.
Loading package bytestring-0.9.1.10 ... linking ... done.
Loading package array-0.3.0.2 ... linking ... done.
Loading package containers-0.4.0.0 ... linking ... done.
Loading package deepseq-1.1.0.2 ... linking ... done.
Loading package text-0.11.0.5 ... linking ... done.
Loading package parsec-3.1.2 ... linking ... done.
ghci> parse p "<string>" "abc"
Right "ab"
ghci> parse p "<string>" "ac"
Left "<string>" (line 1, column 1):
unexpected "c"
expecting "ab"
ghci> parse p "<string>" "d"
Left "<string>" (line 1, column 1):
unexpected "d"
expecting "ab"
ghci> parse p "<string>" ""
Left "<string>" (line 1, column 1):
unexpected end of input
expecting "ab"
ghci> parse (many p) "<string>" "ababc"
Right ["ab","ab"]
ghci> parse (many p) "<string>" "ababa"
Left "<string>" (line 1, column 5):
unexpected end of input
expecting "ab"
ghci> parse (many $ try p) "<string>" "ababa"
Right ["ab","ab"]

所以，many $ try lrcMeta就是不断尝试解析歌词元信息，直到解析失败时停止。

接下来是对歌词数据的解析。因为一行可能有多个时间，我们把它存储成多条LrcLine，所以需要使用concat来连接下每次调用lrcLine返回的结果列表。

自顶向下设计解析器：余下的部分

lrcMeta很简单，一行文本，由中括号括起来，其中的键和值用冒号隔开：

lrcMeta :: GenParser Char st (String, String)
lrcMeta = do
  char '['
  key <- many $ noneOf ":"
  char ':'
  val <- many $ noneOf "]"
  char ']'
  eol
  return (key, val)

lrcLine差不多，不过涉及到时间的解析：

lrcLine :: GenParser Char st [LrcLine]
lrcLine = do
  times <- many1 lrcTime
  line <- many $ noneOf "\r\n"
  optional eol
  return $ map (\t -> LrcLine {
    time = t,
    line = line
  }) times

嗯？没看到对时间的解析？哦，它在这里：

lrcTime :: GenParser Char st Int
lrcTime = do
  char '['
  minutes <- readInt
  char ':'
  second <- readInt
  centisec <- option 0 $ char '.' >> readInt
  char ']'
  return $ 60 * 100 * minutes + 100 * second + centisec
  where readInt = read <$> many digit

好了，你可以编译下试试了。RWH说过了，Compile early, compile often。这样在你不小心出错时，强大的编译器能够及时提示你。

哦，下边是 import 列表：

import Data.Char (isDigit)
import Data.Functor ((<$>))
import Data.List (sort)
import Data.Maybe (isJust, fromJust)
import Text.ParserCombinators.Parsec

你试过了吗？发生了什么？

是的，我还有个「抄袭」RWH的换行符解析器没列出来。链接在文末给出了，大家自己去找吧 ;-)

什么？你没找到？好吧，那你加上这个，也可以编译的了。其实类型的语句早该写的。

eol :: GenParser Char st String
eol = undefined

这样就定义了eol函数，它被定义为一个匹配任意类型的「未定义」值。

最后加点工具函数

一个给把 offset 加到歌词数据里的，另一个则是给歌词在时间轴上偏移一定时间的。

lrcAddOffset :: Lrc -> Lrc
lrcAddOffset l = l { lyrics = ly', metadata = meta' }
  where ly = lyrics l
    meta = metadata l
    offset = lookup "offset" meta >>= parseInt
    ly' = case offset of
          Just t -> addTime (fromInteger t `div` 10) ly
          otherwise -> ly
    meta' = filter notOffset meta
    notOffset = (/= "offset") . fst

addTime :: Int -> [LrcLine] -> [LrcLine]
addTime t = map $ \l -> l { time = (t + time l) }

嗯，还是个parseInt用来把字符串转成整数，并且很好地处理异常。

parseInt :: String -> Maybe Integer
parseInt s = case reads s of
  [(int, "")] -> Just int
  otherwise   -> Nothing

完整代码

-- module Text.Lrc (
--   parseLrc,
--   addTime,
--   lrcAddOffset,
--   Lrc(..),
-- ) where
-- 为测试，这个被注释掉了

import Data.Char (isDigit)
import Data.Functor ((<$>))
import Data.List (sort)
import Data.Maybe (isJust, fromJust)
import Text.ParserCombinators.Parsec

data Lrc = Lrc {
  title :: Maybe String,
  artist :: Maybe String,
  album :: Maybe String,
  by :: Maybe String,
  metadata :: [(String, String)],
  lyrics :: [LrcLine]
}

data LrcLine = LrcLine {
  time :: Int,
  line :: String
} deriving (Eq, Show, Ord)

lrcParser :: GenParser Char st Lrc
lrcParser = do
  metadata <- many $ try lrcMeta
  ly <- concat <$> many lrcLine
  return Lrc {
    title = lookup "ti" metadata,
    artist = lookup "ar" metadata,
    album = lookup "al" metadata,
    by = lookup "by" metadata,
    metadata = metadata,
    lyrics = sort ly
  }

lrcMeta :: GenParser Char st (String, String)
lrcMeta = do
  char '['
  key <- many $ noneOf ":"
  char ':'
  val <- many $ noneOf "]"
  char ']'
  eol
  return (key, val)

lrcLine :: GenParser Char st [LrcLine]
lrcLine = do
  times <- many1 lrcTime
  line <- many $ noneOf "\r\n"
  optional eol
  return $ map (\t -> LrcLine {
    time = t,
    line = line
  }) times

lrcTime :: GenParser Char st Int
lrcTime = do
  char '['
  minutes <- readInt
  char ':'
  second <- readInt
  centisec <- option 0 $ char '.' >> readInt
  char ']'
  return $ 60 * 100 * minutes + 100 * second + centisec
  where readInt = read <$> many digit

eol :: GenParser Char st String
eol = try (string "\n\r")
  <|> try (string "\r\n")
  <|> string "\n"
  <|> string "\r"
  <?> "end of line"

lrcAddOffset :: Lrc -> Lrc
lrcAddOffset l = l { lyrics = ly', metadata = meta' }
  where ly = lyrics l
        meta = metadata l
        offset = lookup "offset" meta >>= parseInt
        ly' = case offset of
                   Just t -> addTime (fromInteger t `div` 10) ly
                   otherwise -> ly
        meta' = filter notOffset meta
        notOffset = (/= "offset") . fst

addTime :: Int -> [LrcLine] -> [LrcLine]
addTime t = map $ \l -> l { time = (t + time l) }

parseInt :: String -> Maybe Integer
parseInt s = case reads s of
  [(int, "")] -> Just int
  otherwise   -> Nothing

main = getContents >>= \lrcfile -> case parse lrcParser "<stdin>" lrcfile of
  Left err -> print err >> error "Failed."
  Right lrc -> mapM_ print $ lyrics $ lrcAddOffset lrc

参考链接

• Real World Haskell: Chapter 16. Using Parsec

学而不用则惘。

任务内容

通过读取 pacman 数据库，获取本机已安装软件包中所有架构相关的软件包名。pacman 的数据库中，包描述文件位于/var/lib/pacman/local/*/desc，其中星号部分为软件包名加版本号。该文件中，%NAME%的下一行为软件包名，%ARCH%的下一行为架构，我这里是i686或者any。任务就是找出所有 i686 的软件包名。

任务解析

先写个纯函数，通过一块描述文本（Data.Text）判断这个包是否是架构相关的。类型声明为：

import qualified Data.Text as T
isArchDependent :: T.Text -> Bool

然后看看我们怎么才能办到这点。首先，用T.lines把这「块」文本解析成行的列表。然后我们来找为%ARCH%的这一行。怎么找呢，把前边的行丢掉好了：

(dropWhile (/= archstart)) . T.lines
  where archstart = T.pack "%ARCH%"

现在列表的第二项就是我们要的架构类别。先取两行，最后一行就是了：

last . (take 2) . (dropWhile (/= archstart)) . T.lines

然后做比较，得到最终的结果：

isArchDependent = (/= anyarch) . last . (take 2) . (dropWhile (/= archstart)) . T.lines
                  where archstart = T.pack "%ARCH%"
                        anyarch = T.pack "any"

知道一个包是不是我们要的了，但我们还不知道它的名字。此信息我可以肯定在第二行，就不慢慢 drop 了：

getPackageName :: T.Text -> T.Text
getPackageName = last . (take 2) . T.lines

再来个筛选函数，把将要显示的包描述信息找出来：

filterArchDependent :: [T.Text] -> [T.Text]
filterArchDependent = filter isArchDependent

接下来，是程序中「不纯」的部分。我们需要列出目录/var/lib/pacman/local下的所有目录，然后读取其中的desc文件。

getPackagePaths :: IO [FilePath]
getPackagePaths = (filter ((/= '.') . head)) `fmap` getDirectoryContents "."

getPackageDesc :: FilePath -> IO T.Text
getPackageDesc = TIO.readFile . (++ "/desc")

最后，把以上这些函数组合起来：

topDir = "/var/lib/pacman/local"

main = do
  setCurrentDirectory topDir
  getPackagePaths >>= mapM getPackageDesc >>= ((mapM TIO.putStrLn) . (map getPackageName) . filterArchDependent)

首先为了避免一大堆的路径拼接，进入topDir里边来。然后（main的第三行）写到：获取所有软件包的路径；对于每个路径，获取对应软件包的描述信息并处理；怎么处理呢？先过滤filterArchDependent，再逐个获取包名，最后把它打印出来。

代码

完整的代码如下：

import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import System.Directory (getDirectoryContents, setCurrentDirectory)
import Control.Monad

isArchDependent :: T.Text -> Bool
isArchDependent = (/= anyarch) . last . (take 2) . (dropWhile (/= archstart)) . T.lines
                  where archstart = T.pack "%ARCH%"
                        anyarch = T.pack "any"

filterArchDependent :: [T.Text] -> [T.Text]
filterArchDependent = filter isArchDependent

getPackageName :: T.Text -> T.Text
getPackageName = last . (take 2) . T.lines

topDir = "/var/lib/pacman/local"

getPackagePaths :: IO [FilePath]
getPackagePaths = (filter ((/= '.') . head)) `fmap` getDirectoryContents "."

getPackageDesc :: FilePath -> IO T.Text
getPackageDesc = TIO.readFile . (++ "/desc")

main = do
  setCurrentDirectory topDir
  getPackagePaths >>= mapM getPackageDesc >>= ((mapM TIO.putStrLn) . (map getPackageName) . filterArchDependent)

性能分析

我使用这个 Perl 脚本来计时，跑 20 次取平均时间。Shell 算起算术来太麻烦了 :-(

#!/usr/bin/perl
 
use Time::HiRes qw(gettimeofday);
 
sub gettime {
  my ($sec, $usec) = gettimeofday;
  $sec * 1000_100 + $usec;
}
 
my $times = 20;
my $start = gettime;
for(my $var = 0; $var < $times; $var++){
  `$ARGV[0]`;
}
my $end = gettime;
printf "%lfus\n", ($end - $start) / $times;

作为对照的是个 Python 脚本：

#!/usr/bin/env python3

import os

topDir = "/var/lib/pacman/local"

def checkPackage(file):
  for l in open(file):
    l = l.rstrip()
    if l == '%NAME%':
      next = 'name'
    elif l == '%ARCH%':
      next = 'arch'
    else:
      if next == 'name':
        name = l
      elif next == 'arch':
        return name, l != 'any'
      next = ''

def main():
  for name in os.listdir(topDir):
    if name.startswith('.'):
      continue
    file = '%s/%s/desc' % (topDir, name)
    name, show = checkPackage(file)
    if show:
      print(name)

if __name__ == '__main__':
  main()

这两个脚本长度都差不多，但效率相差挺显著的：

>>> ~tmp/t.pl './packagestat > /dev/null'
86055.100000us
>>> ~tmp/t.pl './packagestat.py > /dev/null'
248090.450000us

花絮

最开始，我用的是Data.Text.Lazy和Data.Text.Lazy.IO这个包里的 Lazy 文本类型，结果是——

>>> ./packagestat
packagestat: glpng-1.45-4/desc: openFile: resource exhausted (Too many open files)

评论

写完这两个脚本，我体会到了Real World Haskell里说的，Even with years of experience, we remain astonished and pleased by how often our Haskell programs simply work on the first try, once we fix those compilation errors. Haskell 程序基本上编译通过后就能正确运行——只是要先修正各种编译错误。Python 那个跑了几遍才得到正确的结果。不过我觉得，除了 GHC 的强大之外，编写逻辑简单、没有状态变量也是正确率高的重要原因之一。

疑问

如果我想同时统计这些软件包的总大小（包描述信息里有），怎么才能只读一遍这些文件就同时做到这两件事呢？

这是 Stackoverflow 中一篇答案的粗略翻译，原文地址 http://stackoverflow.com/a/2302230/296473^已失效。

1. 没有人听说过它。没有人会使用他们根本不知道的东西。

2. 不够流行。人们认为最流行的语言就是最好的语言，因为如果它不好的话，它就不会流行。实际上这根本不成立。最流行的语言最流行，仅此而已。Haskell 不流行是因为它不流行。这就是 Haskell 里经常用到的「递归」。不管来自命令式编程世界的人们怎么说，递归在现实世界中非常常见。

3. 它不一样。人们总是害怕新事物。

4. 它很难。人们认为 Haskell 难学难用。这显然和第三点有关。Haskell 里充斥着一些高深晦涩的术语，如「单子就是自函子范畴中的独异点，有什么问题吗？」（译注：这句话真难译 :-( ）。普通人可理解不了这个。

5. 有风险。大多数公司不想第一个吃螃蟹。Haskell 的用户太少了，所以很少有用户愿意尝试它。（看吧，又是递归。）

6. 招不到程序员。首先，按第二点，会 Haskell 的人很少。然后，大多数人相信第四点，所以找不到愿意学习的程序员。使用一门招不到程序员的编程语言风险太大了。（好吧，我们回到第五点了。）

7. 库。这可能是最重要的一点，所以我多说一些。

   A. 质量。有很多库，可是质量参差不齐。大多数 Haskell 库（Hackage）是个人的业余项目，文档欠缺。有些不完整，有些已经不再能用，有些在特定情况下会出错。

   B. 多个不兼容的库。你能够使用 Haskell 连接到数据库。但问题是，存在一堆这样的库，让人很难分辨出哪些是被支持的库，哪些在几年前就已经烂掉了。而且，在 Haskell 中连接数据库也不像开个 ODBC 连接那样简单。针对每种数据库，每个库都用不同的后端。在数据库支持的广泛性上 Haskell 做得不错，连新出现的 Mongo 或者 Cassandra 数据库都支持。开源可能没有给予 Haskell 以深度，但给予了其以广度。

   C. Windows。几乎所有重要的库（比如加密、二进制数据文件格式、网络协议、数据压缩、连接数据库等）是 C 语言库的包装。它们在 Windows 上编译不了。因为 Windows 是市场上最大的目标平台，这是个大问题。

8. 效率无法预测。由于对 Haskell 缺乏了解，很多人甚至都不知道这一点。很多人直接就认为「Haskell 效率低下」。这不对。事实是，很难预测一个 Haskell 程序的效率。微妙的、没有明显关联的不同有时可能导致效率的巨大差异。（译注：蝴蝶效应啊？）

9. 正确性。大多数公司对正确性并不重视。它们不在意质量。它们只要尽可能迅速地把代码扔出去赚大把大把的钞票就好了。如果代码有 bug 的话，它们就向客户卖补丁。把代码写对没用；重要的是快速把代码写出来。Haskell 会用优美的解来回馈那些坐下来深入分析问题的人。大多数公司不喜欢这样；他们只要尽可能快地把产品搞出来，以后再修正它，如果还有以后的话。

的确有少数地方正确性很重要。这些地方基本上要么是级别甚高的安全系统，要么是金融系统。（译注：交集不为空？）就我所知，Haskell 在这些领域还是比较流行的。

最后说两点：

• 我还记得不是太久前人们还叫嚷着「C++ 是给菜鸟的玩具！你应该用像 C 这样真正的编程语言。」现在再看看有多少大型 C++ 程序？

• 人们总是在说 Lisp 是「下一个里程碑性语言」。他们说了多久？已经 40 年了？Lisp 比几乎所有主流编程语言都要老。现在看看有多少大型 Lisp 程序？

我不知道 Haskell 的命运终将如何。我觉得，Haskell 好的思想会被像 C# 或者 F#、OCaml 这样的杂交语言偷取。人们依旧不会使用 Haskell。它太不一样了。

不管怎么说，关于为什么业界不用 Haskell，见以上观点。它太罕见、太不流行、太奇特，库也不完善。大约就是这样。

后记：

也许，照耀大地的永远是在众恒星中普普通通的太阳，人们永远不会知道在宇宙的某个角落里曾经诞生过一颗绝美无比的小星星。这个世界是不完美的，否则如果它是完善的，缺少了不完美，它还完美吗？这个世界是不公平的，流星划过苍穹，带给多少人希望，而它自己却身殒，不留下一点痕迹。