実用的なプログラムの話をする

Clojure で実用的なプログラムを書く

こんにちわ、wozozoです。
最近、netty 4ベースのフレームワークを書いてるのですが、速度問題でほぼJavaで書いてしまい、書くことがなくなったので過去に作った実用的なプログラムの話をします。
algo.monads の話でも良かったのですが、他に書かれる方がいるでしょう。
たぶんこんなんを書かれると思います。

(ns cljinja.lexer
  (:use
    [clojure.algo.monads])
  (:require 
    [clojure.string :as str])
  (:import 
    [java.util.regex Pattern]))

(def ^:dynamic *block-begin* "{%")
(def ^:dynamic *block-end* "%}")
(def ^:dynamic *variable-begin* "{{")
(def ^:dynamic *variable-end* "}}")
(def ^:dynamic *comment-begin* "{#")
(def ^:dynamic *comment-end* "#}")

;;
;; Parsec
;;

(def ^:dynamic parser-m (state-t maybe-m))

(defn- return [v]
  (with-monad parser-m
    (m-result v)))

(defn- >>= [p f]
  (with-monad parser-m
    (m-bind p f)))

(defn- >>== [p f]
  (>>= p #(return (f %))))

(defn- <$> [f p]
  (>>= p #(return (f %))))

(defn- >> [p1 p2]
  (>>= p1 (fn [_] p2)))

(defn- either [& parsers]
  (apply (:m-plus parser-m) parsers))

(def <|> either)

(defmacro let-bind
  "Wraps body in `domonad' boilerplate"
  [& body]
  `(domonad parser-m
            ~@body))

(defn- state [data pos line]
  {:data data 
   :pos pos
   :line line})

(defn- inc-newline [line text]
       (+ line (dec (count (str/split (if (char? text) (str text) text) #"\n"))))) 

(defn- any-token [n] 
  (fn [{^String strn :data pos :pos line :line}]
      (when-not (= "" strn)
        (let [data (subs strn 0 n)
              nline (inc-newline line data)]
          [(state data pos line )
           (state (subs strn n) (+ pos n) nline )]))))

(defn- eof [{^String strn :data pos :pos line :line }]
  (when (= "" strn)
    [(state strn pos line )
     (state strn pos line )]))

(defn- nothing [{^String strn :data pos :pos line :line }]
  [(state "" pos line) 
   (state strn pos line)])

(defn- merge-state [x y]
  (reduce (fn [{d1 :data :as m} {d2 :data :as n}] (assoc m :data (str d1 d2))) x y))

(defn stringify [p]
  (>>= p (fn [x] 
             (return 
               (if (vector? x)
                 (merge-state (first x) (next x))
                 x)))))

(defn- satisfy [pred n]
  (domonad parser-m
           [c (any-token n) :when (pred (:data c))]
      c))

(defn- is-char [c]
  (satisfy (partial = c) 1))

(defn- not-char [c]
  (satisfy (partial (comp not =) c) 1))

(defn- is-str [st]
  (satisfy (partial = st) (count st)))

(defn- not-str [st]
  (satisfy (partial (comp not =) st) (count st)))

(defn- optional [p]
  (either p nothing))

(defn- option [default p]
  (either p default))

(defprotocol RegexParser
  (regex [this]))

(extend-protocol RegexParser
  java.lang.String
  (regex [this]
    (let [re (re-pattern (str "^(?:" this ")"))]
      (regex re)))

  java.util.regex.Pattern
  (regex [re]
    (fn [{^String strn :data pos :pos line :line}]
      (let [m (re-find re strn)
            v (if (vector? m) (first m) m)]
        (when-not (or (nil? v))
          (let [len (count v)
                nstr (subs strn len)]
              ; (println (format "'%s'  '%s'  '%s'" re strn nstr))
              [(state v pos line)
               (state nstr (+ pos len) (inc-newline line v))]))))))

(defmacro string-p [^String target]
  `(fn [{^String strn# :data pos# :pos line# :line}]
     (when (.startsWith strn# ~target)
       (let [len# (count ~target)
             nstr# (subs strn# len#)]
           [(state ~target pos# line#)
            (state nstr# (+ pos# len#) (inc-newline line# ~target))]))))

(defmacro not-string-p [^String target]
  `(fn [{^String strn# :data pos# :pos line# :line}]
     (when-not (.startsWith strn# ~target)
       [(state strn# pos# line#) (state strn# pos# line#)])))

(defn- concat% [x xs]
  (let [coll (if (vector? x) x [x])
        coll? (vector? xs)]
    (if coll?
      (into coll xs)
      (if (= "" (:data xs))
        x 
        (conj coll xs)))))

(declare many1)

(defn- many [parser]
  (optional (many1 parser)))

(defn- many1 [parser]
  (let-bind [a parser
             as (many parser)]
             (concat% a as)))

(def aspace (regex #"[\s\r\n]"))
(def spaces (regex #"[\s\r\n]+"))
(def spaces* (regex #"[\s\r\n]*"))

(defn- white-space [p]
  (>> spaces p))

(defn- lexeme [p]
  (let-bind [a p _ spaces] a))

(defn- lexeme* [p]
  (let-bind [a p _ spaces*] a))

(defn- between [open close p]
  (let-bind [_ open
             x p
             _ close]
            x))

(defn sep-by-1 [p sep]
  (let-bind [x p
             xs (many (>> sep p))]
            (concat% x xs)))

(defmacro surround [st#]
  (stringify
    (between 
      (is-char st#)
      (is-char st#)
      (many (not-str st#)))))

(defn- parse [parser input]
  (parser (state input 0 1)))

;; 
;; Rule 
;; 

(def ^:private sp-chars #"([\\\\*+\\[\\](){}\\$.?\\^|])")

(defn- escape-regex [in]
  (str/replace in sp-chars "\\\\$1"))

(defn- build-regex [args]
  (str/join "|" (map escape-regex args)))

(defn- create-regex [tags]
  (Pattern/compile (str "^(.*?)(" (build-regex tags) ")") Pattern/DOTALL))

(defn- text-data-p [regex]
  (fn [{^String strn :data pos :pos line :line }]
    (let [found (re-find (re-matcher (create-regex regex) strn))
          [pair text token] (or found [nil nil nil])]
      (when (and token (not= token pair))
        (let [len (count text)
              nstr (.substring strn (- (.length pair) (.length token)))]
          [(state text pos line)
           (state nstr (+ pos len) (inc-newline line text) )]))))) 

(defmacro token [nm]
  (let [nm# nm]
    `(fn [{^String strn# :data pos# :pos line# :line }]
       {:data strn#
       :pos pos#
       :line line#
       :type ~nm#})))

(def op-array [
               "+" :add
               "-" :sub
               "/" :div
               "//" :floordiv
               "*" :mul
               "%" :mod
               "**" :pow
               "~" :tilde
               ; "[" :lbracket
               ; "]" :rbracket
               ; "(" :lparen
               ; ")" :rparen
               ; "{" :lbrace
               ; "}" :rbrace
               "==" :eq
               "!=" :ne
               ">" :gt
               ">=" :gtEQ
               "<" :lt
               "<=" :ltEQ
               "=" :assign
               "." :dot
               ":" :colon
               "|" :pipe
               "," :comma
               ";" :semicolon])

(def operators (apply array-map op-array))

(defmacro operators-p []
  (let [re (build-regex (keys operators))]
    `(<$> (fn [{^String strn# :data pos# :pos line# :line }]
              {:data strn#
              :pos pos#
              :line line#
              :type (get operators strn#)})
        (regex (str "(" ~re ")")))))

(def string-literal
  (<$> (token :string)
     (<|> (surround "'")
          (surround "\""))))

(def name-p
  (<$> (token :name)
       (regex "[a-zA-Z_][a-zA-Z0-9_-]*")))

(def integer-p
  (<$> (token :integer)
       (regex "\\d+")))

(def float-p
  (<$> (token :float)
       (regex "\\d+\\.\\d+")))

(def ident 
   (<|> string-literal name-p float-p integer-p (operators-p)))

(def text-block
  (<$> (token :data)
       (text-data-p [*variable-begin* *block-begin* *comment-begin* *variable-end* *block-end* *comment-end*])))

(def rest-text
  (<$> (token :data) 
       (fn [{^String strn :data pos :pos line :line }]
           [(state strn pos line )
            (state "" pos line )])))

(def block-begin-p
  (<$> (token :block-begin)
       (lexeme* (is-str *block-begin*))))

(def block-end-p
  (<$> (token :block-end)
       (>> spaces* (is-str *block-end*))))

(def variable-begin-p
  (<$> (token :v-begin)
       (lexeme* (is-str *variable-begin*))))

(def variable-end-p
  (<$> (token :v-end)
       (>> spaces* (is-str *variable-end*))))

(defn- fail-state [{^String strn :data pos :pos line :line }]
  [{:state :fail :data strn :pos pos :line line}
   (state strn pos line)])

(defmacro make-block [begin end gurad]
  `(let-bind [b# ~begin 
              x# (sep-by-1 (>> ~gurad ident) spaces)
              e# (option fail-state ~end)]
             (if (= :fail (:state e#))
               (throw (Exception. (format "Template Syntax Error:%s" e#)))
               (concat% (concat% b# x#) e#))))

(def block-block 
     (make-block 
       block-begin-p block-end-p (not-string-p *block-end* )))

(def variable-block 
     (make-block 
       variable-begin-p variable-end-p (not-string-p *variable-end*)))

(def blocks 
     (many1 (<|> block-block  variable-block text-block)))

(def rule
  (let-bind [c blocks 
             cs rest-text]
            (concat% c cs)))

(defn- lex- [rule input]
  (first (parse rule input)))

(defn lex [input]
  (lex- rule input))

(def input "{% extends 'hoge.html' %}
            test
            {% for item in items %}
            {{ item }}
            {% endfor %}
            ")
(lex- rule input)

本題

というわけで本題

実用的なプログラム？クローラーだろ！

というわけで Clojure でクローラーを書いてみたのを公開しています。
2ch クローラー

元々、PostgreSQLの全文検索の評価を行うために、日本語データをかき集めるために書いたものです。
基本的にキャッシュサーバーからの取得です。

普通に書いてるとバーボンハウス行きになるため並列数を制限する工夫が入っています。
ClojureのfutureマクロはExecutors.newCachedThreadPoolで作られたExecutorServiceを使います。
そのためfutureを使うとバンバンThreadが作られ、並列数は制御できません。
そこでキューに貯めて、必要な数だけワーカーを走らせるようになっています。

(def ^:dynamic *sleep-time* 5000)

(defn dequeue! [queue]
  (loop []
    (let [q @queue
          value (first q)
          nq (next q)]
      (if (compare-and-set! queue q nq)
        value
        (recur)))))

(defn- make-worker [f]
  (let [worker-fn f]
   (fn [q] 
      (when-let [val (dequeue! q)]
        (try
          (debug (format "start call worker val:%s" val))
          (worker-fn val)
          (debug (format "end call worker val:%s remain:%s" val (count @q)))
          (catch Exception e (error e)))
        (debug (format "wait:%s ... " *sleep-time*))
        (Thread/sleep *sleep-time*)
        (recur q)))))

(defn start-worker [q f nthread]
  (let [p (promise)
        cnt (atom nthread)]
    (dotimes [i nthread]
      (future 
        ((make-worker f) q)
        (if (= 0 (swap! cnt dec))
          (deliver p "OK"))))
    p))

問題は並列にキューに値を突っ込んだり、出したりするわけでそこをどう実装するかってとこです。
あまり使われてるのを見たことがないのですがcompare-and-set!で値を比較、問題なければ値を返しています。失敗（この間に別 Thread によって値が変わった）場合にはリトライしています。
いわゆるCASですね。
スクレイピング、データベースアクセス、スレッドなど定番処理が入ってるので良いサンプルだと思います。

実用的なプログラム？やっぱクローラーだろ！

はい、次もやはりクローラーでしょうか。
元々はcore.asyncが出たばっかの頃に試してみたくて書いたものです。
全部は言いませんが、要は小さな図書館を作るクローラーです。
hentai

core.asyncのサンプルとしてはなかなか良いサンプルだと思います。
他にclojure.tools.logging,コマンドラインのオプションを処理する clojure.tools.cliも使っています。
他にも書かれている方もいるかと思いますが goマクロはCPU数 + 2 のスレッドプールで処理を行います。そのため、ガンガン goマクロを使っても並列数は一定になります。
並列数を制限したくない場合には thread マクロを使うと良いでしょう。
またgoマクロ内で例外が発生しても握りつぶされてしまうので必ずキャッチしてchannelなどを使って知らせるようにするべきです。

というわけで特にネタがないので過去のネタを使いまわしたという話でした。