サンタとConduit (Haskell Advent Calendar 23日目)

※これはHaskell Advent Calendar 2012の23日目の記事です。

もうすぐクリスマスです。サンタクロースの皆さんはそろそろ子供達にプレゼントを配る用意をしなければいけません。ところで、最近のサンタクロースはIT化が進み、どうやらHaskellでプレゼントを配るシステムを使っているそうです。新米サンタさんはクリスマスまでの残り2日で、このシステム通りにプレゼントを配る方法を覚えなければいけません。新米サンタさんはどうやらHaskellの基本的な使い方は覚えたようですが、このプレゼント配送システムに"Conduit"という聞きなれない物が使われているので、うまく扱えるか心配です。

Conduitは主にストリーム処理用に作られたライブラリで、Source, Sink, そしてConduitをうまく繋いで処理を行います。Sourceは上流からストリームを流し、Sinkは最終的に流れてきたストリームを消費して何か処理をします。ConduitはSourceとSinkの間に置き、Sourceから流れてきたストリームに何らかの処理を施し、それをSinkに向けて再び流します。

では、例のプレゼント配送システムを見てみましょう。

christmas :: Monad m => m ()
christmas = sourceRequest
            $$ santaClaus
            =$ sinkChildren

sourceRequestは何だかよく分からないけど子供達からのプレゼントのリクエストが流れてくる物で、sinkChildrenは何だかよく分からないけど渡したプレゼントが子供達に届く物です。Sourceの中身もSinkの中身もよくわからないのに間のConduitを書けるのも、Conduitの利点の1つです。

上のソースをもう少し見てみましょう。christmasではSourceであるsourceRequest、SinkであるsinkChildren、ConduitであるsantaClausの他に、何やら見慣れない$$とか=$とかいう演算子が混ざっています。

この2つの演算子のうち、$$演算子のほうはSourceとSinkを繋いで処理を実行します。

ghci> runResourceT $ sourceFile "input.txt" $$ sinkFile "output.txt"

この例の場合、sourceFileはinput.txtの中身を読み取ってSinkに送り、sinkFileではSourceから受け取った内容をoutput.txtに書き込みます。

もう1つの=$演算子はConduitとSinkを繋ぎ、1つのSinkに合成します。例えば、上の例でinput.txtの各行の先頭に"hoge"と付け足したい場合は、

ghci> runResourceT $ sourceFile "input.txt"      -- input.txtを…
                   $$ Data.Conduit.Binary.lines  -- 行ごとに分けて…
                   =$ Data.Conduit.List.map      -- 各行の先頭に"hoge"を足して…
                       (\s -> "hoge" `append` s `append` "\n")
                   =$ sinkFile "output.txt"      -- output.txtに出力

というようにします。この場合、4行目のSinkと3行目のConduitが合成されて1つのSinkになり、さらにそれと2行目のConduitが合成されて1つのSinkになり、そのSinkと1行目のSourceが合成され、runResourceTによって実行されます。この他にも、SourceとConduitを合成して新たなSourceを作る$=演算子や、ConduitとConduitを合成する=$=演算子などもあります。

先程の例をもう一度見てみましょう。

christmas :: Monad m => m ()
christmas = sourceRequest
            $$ santaClaus
            =$ sinkChildren

この例では、sinkChildrenとsantaClausが合成されて1つのSinkとなり、それがSourceであるsourceRequestと合成されています。

では、間にいるサンタは一体何をやればよいでしょう？

santaClaus = do
  ...

まずはSourceとSinkの型を見てみましょう。

ghci> :t sourceRequest 
sourceRequest :: Monad m => Source m Request
ghci> :t sinkChildren 
sinkChildren :: Monad m => Sink Present m ()

soureRequestやsinkChildrenがどのような実装になっているかは分かりませんが、とりあえずコードを動かすために、以下のように暫定的な定義をしておきましょう。実際のSourceやSinkと違っても、上流から受けとるデータの型と下流へ流すデータの型さえ合っていれば、ConduitはどのようなSourceやSinkにも使うことができます。

import Data.Conduit
import qualified Data.Conduit.List as CL

data Request = Request {
   reqPresent :: String
 , reqFrom :: String
 } deriving (Show, Eq)

data Present = Present {
    presentName :: String
  } deriving (Show, Eq)

sourceRequest :: Monad m => Source m Request
sourceRequest = CL.sourceList [
  ...
  ]                

sinkChildren :: Monad m => Sink Present m ()
sinkChildren = CL.consume >> return ()

先程の型情報によると、どうやら渡されたRequestに対応するPresentをsinkChildrenに送ってやればいいみたいです。これでsantaClausの型は決まりました。

santaClaus :: Monad m => Conduit Request m Present
santaClaus = do
  ...

とにかくプレゼントのリクエストを見ないと何も始まらないので、まずは上流のSourceから1つリクエストを受け取ってみましょう。

mreq <- await

awaitはSourceからデータを1つ受け取って返す関数です。Sourceから受け取ることのできるデータが1つも無い場合はNothingを返します。Sourceから渡されたのは以下のようなプレゼントのリクエストでした。

Just (Request { 
    reqFrom = "葉月"
  , reqPresent = "絵本"
})

葉月ちゃんという子から、絵本のリクエストが来ました。早速プレゼントを用意しましょう。

yield $ Present "絵本"

yieldは引数に取った値を下流のSinkやらConduitに渡す関数です。これで渡したプレゼントはsinkChildrenが25日に子供に届けてくれるでしょう。ともかく、これでまず一人分のプレゼントの用意が終わりました。同じようにもう1度やってみましょう。

mreq <- await -- => Just (Request { reqFrom = "恋", reqPresent = "牛乳" })
yield $ Present "牛乳"

今度は恋(れん)ちゃんという子のために牛乳を用意してあげました。この調子で全員分のプレゼントを用意しましょう。実は、このようなパターンはawaitForever関数を使って楽に書くことができます。

santaClaus = awaitForever $ \req -> yield $ reqPresent req

awaitForeverは、「上流から流れてくるデータを1つ受け取り、引数の関数の引数に渡して実行する」という動作を上流からデータが流れてこなくなるまで実行し続けます。今回のように上から流れてくるデータを1つずつ変換して下に流すだけのコードを書く時には便利です。

おっと、まだ2人分のプレゼントしか用意し終えていないのに、サンタさんは疲れて休憩に入ってしまいました。

return ()

クリスマスまであと2日しかありません。世界中の子供達の分のプレゼントを用意しなければならないので、こんな所で休んでいる場合ではありません。

Conduitでは、Source等が簡単に自分が生産するデータが下流で使い果たされたかどうかを知ることができます。Sourceがまだデータを生産できる状態で下流の動作が終了してしまった場合、Sourceでは終了処理が呼ばれます。Sourceに終了処理を追加する一番簡単な方法はaddCleanup関数を使うことです。試しに、以下のような2人のサンタクロースを例にこの関数を使ってみましょう。

lazySanta, diligentSanta :: Monad m => Conduit Request m Present

-- 1つ処理して終了("遅延評価"という意味のlazyではない)
lazySanta = do
  mreq <- await
  case mreq of
    Nothing -> return ()
    Just req -> do
      yield $ reqPresent req

-- 全部処理する
diligentSanta = awaitForever $ \req -> yield $ reqPresent req

addCleanupを用いて終了処理に追加するのは以下のような関数です。

check :: Bool -> IO ()
check finished = putStrLn $ if finished
                            then "お疲れ様!"
                            else "まだ残ってるよ!!!"

addCleanupにより追加される終了処理の関数に渡される引数は、上流がもうストリームに流せるデータを持っていない場合はTrue、そうでない場合はFalseとなります。これを使って挙動を確かめてみましょう。

ghci> addCleanup check sourceRequest $$ diligentSanta =$ sinkChildren 
お疲れ様!
ghci> addCleanup check sourceRequest $$ lazySanta =$ sinkChildren 
まだ残ってるよ!!!

しかし、Conduitの終了処理には1つ罠があります。以下のようなサンタで同じ事をやってみましょう。

-- 何もしない
laziestSanta :: Monad m => Conduit Request m Present    
laziestSanta = return ()

結果は以下のようになります。

ghci> addCleanup check sourceRequest $$ laziestSanta =$ sinkChildren 
ghci> 

何も表示されませんでした! 一体どういうことでしょう!?

実は、この原因はSource, Conduit, Sinkの実行の順番にあります。

Conduitは、まずストリームの最下流を実行し、最下流のSinkが何かデータを要求することで初めて上流の実行をします。そのため、SinkがSourceに対して1つのデータも要求しなかった場合、Sinkはそもそも開始すらされないので、終了処理が呼ばれる事もありません。

また、サンタがストリームの処理をやめてしまった場合、別のサンタに処理の続きを引き継いでもらうこともできます。

ghci> (next, _) <- addCleanup check sourceRequest $$+ santa1 =$ sinkChildren
ghci> (next', _) <- next $$++ santa2 =$ sinkChildren
ghci> next' $$+- santa3 =$ sinkChildren 
お疲れ様!

$$+やら$$++やら$$+-やら、続々と見慣れない演算子が登場してきました。しかし心配はいりません。1つずつ機能を見ていきましょう。$$+演算子はSourceとConduitを結合し、実行結果とSourceの続きを返します。

($$+) :: Monad m => Source m a -> Sink a m b -> m (ResumableSource m a, b)

返ってきたSourceの続きはResumableSourceという、Sourceとは別な型になっています。これをSinkと結合するには、今までの$$演算子ではなく$$++演算子か$$+-演算子を使います。$$++演算子はResumableSourceとSinkを結合し、実行結果と残りのResumableSourceを返すのに対し、$$+-演算子は実行結果のみを返し、ResumableSourceの終了動作を行います。

これだけのことを覚えれば、あとは基本的なConduitなら使いこなせるはずです。サンタさんもこれで安心してプレゼントを配達することができます。

暫定的なドットファイルの管理方法

いい加減新しい環境を構築するたびにscpとかで必要なファイルを1つ1つコピーする作業にも飽きてきたので、とりあえずこんな感じのスクリプトを書いてdropboxでドットファイルを管理することにしました。

#!/bin/bash

dir="$(pwd)/dotfiles"
sync_to="$HOME"

find "$dir" -mindepth 1 -maxdepth 1 | while read from; do
    from=$(realpath "$from")
    to="$sync_to/${from##*/}"
    

    if [ -L "$to" ]; then
        rm "$to"                            # 元々あったリンクは問答無用で削除
    elif [ -f "$to" -o -d "$to" ]; then
        mv "$to" "$to.bak"                  # ファイルはバックアップ取っておく
    fi
    
    ln -s "$from" "$to"
done

~/Dropbox以下にdotfilesとか適当なディレクトリを作り、そこに他のPCと同期させたいファイルを詰め込み、あとはファイルを追加する毎にこのスクリプトを実行するなりcronで定期的に実行するようにするなりすればドットファイルが同期されます。

BrainFuckのコードをHaskellに埋め込む (Esolang Advent Calendar 2012 7日目)

ソースコード内にBrainFuckのコードを直で書ける。そう、Haskellならね。

main :: IO ()
main = "+++++++++[>++++++++<-]>.<++++[>+++++++<-]>+.+++++++..+++.<+++++++++[>---------<-]>++.<++++++++++[>+++++++++<-]>---.--------.+++.------.--------.<++++++++[>--------<-]>---.<++++[>------<-]>+."

実行結果:

(／・ω・)／> runghc Example.hs
Hello world!

仕掛け:

GHCにはOverloadedStringsという便利な拡張機能が用意されており、これを使うと文字列リテラルをIsStringクラスのインスタンスの任意の型として扱うことができます。

ghci> :set -XOverloadedStrings
ghci> :m Data.String
ghci> instance IsString Int where fromString = read
ghci> "3" + "4" :: Int -- 文字列が自動的にInt型に変換されている
7

これを利用して、IO a型をIsStringのインスタンスにし、文字列リテラルをIO a型に変換する際に文字列中のBrainFuckコードを実行する関数を作れば完成です。ソースコードは長くなるので最後に載せますが、以下の説明ではそのモジュールがBrainFuckという名前でインストールされていると仮定します。

使い方:

単純に1つのBrainFuckコードを実行したいだけの場合は、先程のようにIO aなアクションを書くべき部分に代わりにBrainFuckコードを書くだけでOKです。

{-# LANGUAGE OverloadedStrings #-}
import BrainFuck

main :: IO ()
main = "+++++++++[>++++++++<-]>.<++++[>+++++++<-]>+.+++++++..+++.<+++++++++[>---------<-]>++.<++++++++++[>+++++++++<-]>---.--------.+++.------.--------.<++++++++[>--------<-]>---.<++++[>------<-]>+."

BrainFuckコードの間にHaskellの関数を挟みたい場合は、BrainFuckモナドを使います。これはBrainFuck実行用の仮想メモリや、現在読み込んでいる命令の位置などを保存するためのモナドです。

main' :: IO ()
main' = runBrainFuck $ do
  "++++++++[>++++++++<-]>++."
  "<++++++[>++++++++<-]>."
  "<+++[>-----<-]>--."
  "++++++++."
  "+++++."
  liftIO $ putStr " Haskell "
  "<+++++[>--------<-]>."
  "<+++++++[>+++++++<-]>--."
  "<+++[>------<-]>."
  "++++++++."
  "<++++++++[>---------<-]>--."
  "<++++[>------<-]>+."

実行結果は以下のようになります。

ghci> main'
Brain Haskell Fuck!

上の例だと、"Brain"と"Fuck!"はBrainFuckコードを実行して表示される文字列で、間の" Haskell "はHaskellのコードによって出力されています。

ソース

{-# LANGUAGE RecordWildCards, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}

module BrainFuck (
    runBrainFuck
  , BrainFuck
  ) where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State
import Data.Array
import Data.Array.IO
import Data.Char
import Data.Default
import Data.Functor
import Data.Lens.Lazy
import Data.Lens.Template
import Data.String
import Data.Word (Word8)

type BrainFuck = StateT BFState IO

data Command = Plus | Minus | Next | Prev | Loop | Break | Get | Put | End
             deriving (Eq, Show)

data BFState = BFState {
    _memory :: IOArray Int Word8
  , _commands :: Array Int Command
  , _memoryIndex :: Int
  , _commandIndex :: Int
  , _loopBreak :: Bool
  }

instance Default BFState where
  def = BFState {
      _memory = undefined
    , _commands = listArray (0, 0) [End]
    , _memoryIndex = 0
    , _commandIndex = 0
    , _loopBreak = False
    }

$(makeLenses [''BFState])

runBrainFuck' :: BrainFuck a -> BFState -> IO a
runBrainFuck' = evalStateT

runBrainFuck :: BrainFuck a -> IO a
runBrainFuck code = do
  mem <- defaultMem
  evalStateT code def { _memory = mem }

buildCode :: String -> [Command]
buildCode = foldr step []
  where
    step '+' xs = Plus : xs
    step '-' xs = Minus : xs
    step '>' xs = Next : xs
    step '<' xs = Prev : xs
    step '.' xs = Put : xs
    step ',' xs = Get : xs
    step '[' xs = Loop : xs
    step ']' xs = Break : xs
    step _   xs = xs

appendCode :: String -> BrainFuck ()
appendCode code = do
  old <- filter (/= End) . elems <$> access commands
  let new = buildCode code ++ [End]
  let cmds = old ++ new
  void $ commands  ~= listArray (0, length cmds - 1) cmds

modifyArray :: (Ix i, MArray a e m) => a i e -> i -> (e -> e) -> m ()
modifyArray arr i f = readArray arr i >>= writeArray arr i . f

defaultMem :: IO (IOArray Int Word8)
defaultMem = newArray (0, 32767) 0

interpret :: BrainFuck ()
interpret = do
  BFState {..} <- get
  case _commands ! _commandIndex of
    Plus -> do
      mem <- liftIO $ modifyArray _memory _memoryIndex (+1)
      commandIndex %= (+1)
      interpret
    Minus -> do
      mem <- liftIO $ modifyArray _memory _memoryIndex (subtract 1)
      commandIndex %= (+1)
      interpret
    Next -> do
      memoryIndex %= (+1)
      commandIndex %= (+1)
      interpret
    Prev -> do
      memoryIndex %= (subtract 1)
      commandIndex %= (+1)
      interpret
    Loop -> do
      commandIndex %= (+1)
      interpret
      break <- access loopBreak
      case break of
        True -> do
          loopBreak ~= False
          commandIndex ~= _commandIndex
          interpret
        False -> return ()
    Break -> do
      c <- liftIO $ readArray _memory _memoryIndex
      case c of
        0 -> do
          commandIndex %= (+1)
          interpret
        _ -> do
          loopBreak ~= True
          return ()
    Get -> do
      c <- liftIO getChar
      liftIO $ writeArray _memory _memoryIndex $ fromIntegral $ ord c
      commandIndex %= (+1)
      interpret      
    Put -> do
      c <- liftIO $ readArray _memory _memoryIndex
      liftIO $ putChar $ chr $ fromIntegral c
      commandIndex %= (+1)
      interpret
    End -> return ()


instance IsString (IO a) where
  fromString src = do
    mem <- defaultMem
    runBrainFuck' interpret def {
        _memory = mem
      , _commands = listArray (0, length cmds - 1) cmds
      }
    return undefined
    where
      cmds = buildCode src ++ [End]

instance IsString (BrainFuck a) where
  fromString src = appendCode src >> interpret >> return undefined

明日は@k_operafanさん、よろしくお願いします!

YesodからCoffeeScriptを使う

Yesodが使用しているShakespearean Templatesのモジュールの1つであるshakespeare-jsには、CoffeeScript用の関数も用意されてあります。残念ながらデフォルトのままではwidgetFile関数を使ったビルド時の外部ファイルの読み込みには対応していませんが、Settings.hsにあるwidgetFileSettingsを以下のように変更することで、CoffeeScriptをビルド時に自動的にJavaScriptに変換して読み込んでくれるようになります。

import Text.Coffee

widgetFileSettings :: WidgetFileSettings
widgetFileSettings = def
    { wfsHamletSettings = defaultHamletSettings
        { hamletNewlines = AlwaysNewlines
        }
    , wfsLanguages = \hamletSet -> coffeeSet : defaultTemplateLanguages hamletSet
    }
  where
    coffeeSet = TemplateLanguage {
        tlRequiresToWidget = True
      , tlExtension = "coffee"
      , tlNoReload = coffeeFile
      , tlReload = coffeeFileReload
      }

もう1つハマった部分が。CoffeeScriptで文字列中にCoffeeScriptの式を展開したい場合の記法と、Shakespearean Templatesでテンプレートファイル内にHaskellの式を展開したい場合の記法は、どちらも

message = "#{name}ちゃんぺろぺろ"

となっているので、Haskellの変数展開の記法がCoffeeScriptの文法と被ってしまって使うことができなくなります。しかし、CoffeeScriptの場合のみHaskellの式展開の記法が以下のように変更されているので、CoffeeScript側の式展開もHaskell側の式展開も問題なく使うことができます。

message = "%{name}ちゃんぺろぺろ"

さらにもう1つハマった部分が。これは単なるCoffeeScriptの仕様なのですが、CoffeeScriptはデフォルトではコンパイル後のJavaScript全体を無名関数で括ってしまい、グローバル変数が作られないようにしてしまうので、別ファイルからも参照したい関数や変数は、

this.func = -> alert "%{name}ちゃんぺろぺろ"

または単純に

@func = -> alert "%{name}ちゃんぺろぺろ"

と書かなければいけません。

Googleカレンダーの予定を妹が通知してくれるスクリプト

勉強の予定なんかを妹が教えてくれれば少しはやる気も出るかと思い、CoffeeScriptの練習を兼ねて書いてみました。

randomMessage = ->
    baseMessages = [
        "終わったら、一緒に遊んでね!!"
        "私と遊ぶ予定は無いの〜?"
        "予定ばっかりこなしてないで、もっと私のこともかまってよ〜＞＜"
        "お兄ちゃん、頑張って!"
    ]
    hour = (new Date).getHours()
    messages =
        if 3 <= hour <= 6
            baseMessages.concat [
                "ふぁぁ〜、まだ早朝だよぉ…"
                "お兄ちゃん、起きてよぉ〜＞＜"
                "お兄ちゃんに予定教えるために早起きしたんだよ! えらいでしょ〜♪"
                "それじゃ私はもっかい寝るね…Zzz…"
            ]
        else if 7 <= hour <= 9
            baseMessages.concat [
                "今日もがんばってね♪"
                "朝ごはん、ちゃんと食べた?"
            ]
        else if 10 <= hour <= 12
            baseMessages.concat [
                "そろそろお昼ごはん食べようよ〜!"
            ]
        else if 13 <= hour <= 16
            baseMessages.concat [
                "予定終わったら、一緒におやつ食べようね!"
                "お兄ちゃんが予定こなしてる間、私はおひるねしてこよ〜っと♪"
            ]
        else if 17 <= hour <= 19
            baseMessages.concat [
                "晩ごはん作ったから、予定終わったら一緒に食べようね♪"
            ]
        else if 20 <= hour <= 22
            baseMessages.concat [
                "それじゃ、私はお風呂入ってくるね♪"
                "ふぁぁ…少し眠くなってきちゃった…"
            ]
        else if 23 <= hour or hour <= 2
            baseMessages.concat [
                "ふぇぇ…眠いよぉ…"
                "お兄ちゃん、もう夜中だしそろそろ寝ようよぉ…"
                "予定終わったら一緒に寝ようね♪"
            ]
    return messages[Math.floor Math.random() * messages.length]

reminder = ->
    before = 5 # 何分前に通知してほしいかをここに書いてね!
    mailTo = "hogehogefoobar@expamle.com" # 送信先だよ!
    now = new Date
    calendar = CalendarApp.getDefaultCalendar()
    events = calendar.getEventsForDay now
    
    for event in events
        start = event.getStartTime()
        if start.getHours() is now.getHours() and \
              start.getMinutes() is now.getMinutes() + before
            # もうすぐ始まる予定をメールで通知するよ!
            startTime = Utilities.formatDate start, "JST", "HH:mm"
            endTime = Utilities.formatDate event.getEndTime(), "JST", "HH:mm"
            title = event.getTitle()
            subject = "お兄ちゃん、「#{title}」の時間だよ♪"
            body = """
            お兄ちゃん、#{startTime}から#{endTime}までの間、「#{title}」をする予定だったよね?
            #{randomMessage()}
            """
            MailApp.sendEmail mailTo, subject, body

使用方法

まずは上のスクリプトをcoffeeコマンドでJSにコンパイルします。

$ coffee -cb hoge.coffee

次に、Googleドキュメントで適当なスプレッドシートを開き、「ツール」→「スクリプトエディタ」をクリックして出てきた場所にコンパイル後のJSを貼り付けます。

このままだとスクリプトエディタさんが関数を認識してくれないので、貼り付けたJSの以下の部分を変更します。

// Generated by CoffeeScript 1.4.0
var randomMessage, reminder;

// (中略)

reminder = function() {

// (後略)

この部分を、

// Generated by CoffeeScript 1.4.0
var randomMessage;

// (中略)

function reminder() {

// (後略)

このように書き換えます。

最後に、メニューの「リソース」→「現在のスクリプトのトリガー」から、reminder関数を1分おきに実行するようにすれば、予定を妹が通知してくれるようになります。あとはつまらないfuckingなGoogleカレンダーのデフォルトの通知メールをすべてoffにしてやりましょう!!