undefinedの代わりに$notImplementedを使おう

Haskellで一からコードを書くとき、よく型だけ書いて実装はundefinedにすることがあります。これはとても便利な常套手段なんですが、規模が大きくなってきたり、undefinedな数が多くなってくると不便に思うこともあります。

undefinedとplaceholders

一通り関数とその型の概要ができてきて、小さく動かせる範囲で実装していきましょうという段階に入ると、動かしながら実装したくなるものです。

このとき未実装の部分をundefinedにしておくと、実行時には例外が上がります。残念なことにこの例外はどこから上がったものなのかエラーメッセージを見てもわかりません。

例えばこんな感じ…

Foo: Prelude.undefined

これじゃつらいので行番号を出せるようにします!というのがplaceholdersライブラリです。

使い方は簡単で、

f :: MonadFooBar m => m [a]
f = undefined

みたいにしていたところを

{-# LANGUAGE TemplateHaskell #-}
import Development.Placeholders

f :: MonadFooBar m => m [a]
f = $notImplemented

に変えるだけ。ほかにもtodo専用もあります。

g = $(todo "ご飯食べてから実装する")

undefinedとの違いは、実行時に行番号を出してくれるだけでなく、コンパイル時に警告を出してくれる*1ので、git grep undefinedしなくても実装し忘れることがないという利点があります。こんな感じ。

src/FooBar.hs:38:7: Unimplemented feature

src/FooBar.hs:39:9: TODO: ご飯食べてから実装する

仕組みも単純で、Template Haskellでもって行番号を入れているだけです。

欠点と言えば、各ファイルにTemplateHaskellの指定とimport文を書く必要があることです。前者はcabalファイルにextensionsで指定すればいいものの、後者はどうしようもありません。

プリプロセッサplaceholders

そこで全モジュールに自動的にimport Development.Placeholdersを挿入するGHCプリプロセッサを書きました。これを使うと、ソースコード中にimport文を書かなくてもよくなります。

pull requestがまだ取り込まれてないので、インストールにはGitHubにあるソースが必要です。

git clone git://github.com/maoe/placeholders.git
cd placeholders
git checkout feature/preprocessor
cabal install # もしくはcabal-dev installなどお好みで

これで~/.cabal/configに指定されているexecutableのインストール先にplaceholdersというバイナリがインストールされます。PATHが通っている事を確認しておきましょう。

あなたのプロジェクトで実際に使うには、cabalファイルにはこんな風に指定するといいでしょう。

flag devel
  default: False

library
  ...
  if flag(devel)
    extensions: TemplateHaskell
    ghc-options: -F -pgmF placeholders
    build-depends: placeholders

こうすることで、cabal buildするとGHCが前処理の段階でplaceholdersを実行し、各モジュールの適切な場所に

import Development.Placeholders

という行を追加してくれるので、あとは必要なところに

f = $notImplemented

だの

g = $(todo "やる気が出たら実装する")

など書いていくだけです。

既知の問題

現時点では、このプリプロセッサはいくつか問題があります。pull request歓迎です。

  • CPPを有効にしていると、エラーメッセージの行番号がずれる
  • 何も考えずに全開importするので、notImplementedとかtodoなどの識別子がコンフリクトする可能性がある。
  • UnicodeSyntaxには対応してない。

書いた本人がまだそれほど使い込んでないので使い勝手がどうか分かりませんが、もしかしたら便利かもしれません。

*1:productionでは-Werrorとしておけば、コンパイルでこけてくれる

htmlcatをSnap対応させました

htmlcatをwai + warpだけでなくsnap-core + snap-serverでも動くようにしてみました。なるべく似たようなコードになるように書いてみました。とても似ています。

Snapだとこんな感じ。

{-# LANGUAGE OverloadedStrings #-}
module HtmlCat.Snap (feedStdIn, runHtmlCat) where
import Control.Concurrent (Chan, writeChan, forkIO)
import Control.Monad (void)
import Control.Monad.Trans (MonadIO(..))
import Data.Text (Text)
import System.IO (stdin)
import qualified Data.ByteString.Char8 as B8

import Data.Enumerator (Iteratee, Enumeratee, ($$), ($=))
import Snap.Core
import Snap.Http.Server (simpleHttpServe)
import Snap.Http.Server.Config
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import qualified Blaze.ByteString.Builder.Char.Utf8 as B
import qualified Data.Enumerator as E (run_)
import qualified Data.Enumerator.List as E (map, foldM)
import qualified Data.Enumerator.Text as E (enumHandle)

import HtmlCat.Html (html)
import Snap.EventSource (ServerEvent(..), eventSourceApp)

feedStdIn :: Chan ServerEvent -> IO ()
feedStdIn chan = void . forkIO $ E.run_ $
  sourceStdIn $= textsToEventSource $$ sinkChan chan

runHtmlCat :: Chan ServerEvent -> String -> Int -> IO ()
runHtmlCat chan host port =
  simpleHttpServe (setPort port $ setBind (B8.pack host)
                                $ defaultConfig :: Config Snap ())
                  (app chan)

app :: Chan ServerEvent -> Snap ()
app chan = route [ ("",       appTop)
                 , ("stream", appStream chan)
                 ]

appTop :: Snap ()
appTop = writeBuilder $ renderHtmlBuilder html

appStream :: Chan ServerEvent -> Snap ()
appStream = eventSourceApp

sourceStdIn :: MonadIO m => Enumerator Text m a
sourceStdIn = E.enumHandle stdin

textsToEventSource :: Monad m => Enumeratee Text ServerEvent m a
textsToEventSource = E.map f
  where
    f text = ServerEvent { eventName = Nothing
                         , eventId   = Nothing
                         , eventData = [B.fromText text] }

sinkChan :: MonadIO m => Chan a -> Iteratee a m ()
sinkChan chan = E.foldM go ()
  where
    go () a = liftIO $ writeChan chan a

WAIだとこんな感じ。

{-# LANGUAGE OverloadedStrings #-}
module HtmlCat.Wai (feedStdIn, runHtmlCat) where
import Control.Concurrent (Chan, writeChan, forkIO)
import Control.Monad (void)
import Control.Monad.Trans (MonadIO(..))
import Data.Text (Text)
import Prelude hiding (lines)
import System.IO (stdin)
import qualified Data.Text as T

import Data.Conduit (($$), ($=), ResourceIO, Source, Sink, SinkResult(..), Conduit, runResourceT, sinkIO)
import Data.Conduit.Binary (sourceHandle)
import Data.Conduit.Text (decode, utf8)
import Network.HTTP.Types (headerContentType, statusOK, statusNotFound)
import Network.Wai (Application, Request(..), Response(..), responseLBS)
import Network.Wai.EventSource (ServerEvent(..), eventSourceApp)
import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsHost, settingsPort)
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import qualified Blaze.ByteString.Builder.Char.Utf8 as B
import qualified Data.Conduit.List as CL

import HtmlCat.Html (html)

feedStdIn :: Chan ServerEvent -> IO ()
feedStdIn chan = void . forkIO . runResourceT $
  sourceStdIn $= lines $= textsToEventSource $$ sinkChan chan

runHtmlCat :: Chan ServerEvent -> String -> Int -> IO ()
runHtmlCat chan host port =
  runSettings (defaultSettings { settingsHost = host
                               , settingsPort = port })
              (app chan)

app :: Chan ServerEvent -> Application
app chan req =
  case pathInfo req of
    []         -> appTop req
    ["stream"] -> appStream chan req
    _          -> app404 req

appTop :: Application
appTop _ = return $
  ResponseBuilder statusOK
                  [headerContentType "text/html; charset=utf-8"]
                  (renderHtmlBuilder html)

appStream :: Chan ServerEvent -> Application
appStream = eventSourceApp

app404 :: Application
app404 _ = return $ responseLBS statusNotFound [] "Not found"

sourceStdIn :: ResourceIO m => Source m Text
sourceStdIn = sourceHandle stdin $= decode utf8

lines :: Monad m => Conduit Text m [Text]
lines = CL.map T.lines

textsToEventSource :: Monad m => Conduit [Text] m ServerEvent
textsToEventSource = CL.map f
  where
    f texts = ServerEvent { eventName = Nothing
                          , eventId   = Nothing
                          , eventData = map B.fromText texts }

sinkChan :: ResourceIO m => Chan a -> Sink a m ()
sinkChan chan = sinkIO noop (const noop) push return
  where
    noop = return ()
    push _ a = do
      liftIO $ writeChan chan a
      return Processing

snap-coreがwaiと、snap-serverがwarpと対応しています。HTMLのレンダリングはSnapフレームワークにはheistというライブラリがあるのですが、どう見てもYesod陣営のhamletの方が使いやすいので、Snapでもhamletを使っています。

Server-sent eventsの対応はwai-eventsourceに相当するものがSnapにないので、Snap.EventSourceをほぼコピペして入れてあります。snap-eventsourceとしてHackageにあげておこうかと思っています。

標準入力をブラウザでtail -fできるhtmlcatをHaskellで書いた

GNU screen 使っているとはいえ開発中に諸々のログを流しておくのにウィンドウ使うのに慣れてなくて、タブ開きまくるならやっぱりブラウザを使いたいってことで、標準入力をブラウザに出してくれるツールを書きました。

標準入力をブラウザで tail -f できる htmlcat というのを書いた - NaN days - subtech

というのを動かしてみたかったのですが、Perlの環境整備がうまくいかなかったので、Haskellで書いてみました。コードは短いのでここに貼っておきます。

maoe/htmlcat · GitHub

{-# LANGUAGE ScopedTypeVariables, QuasiQuotes, OverloadedStrings, RecordWildCards, DeriveDataTypeable #-}
module Main where
import Control.Concurrent (Chan, newChan, writeChan, forkIO)
import Control.Exception (IOException, try)
import Control.Monad (void)
import Control.Monad.Trans (MonadIO(..), MonadTrans(..))
import Data.Foldable (forM_)
import Data.Maybe (maybeToList)
import Data.Text (Text)
import Network (PortID(..), listenOn, sClose)
import System.IO (stdin)
import System.Process (rawSystem)
import qualified Data.Text as T
import Prelude hiding (lines)

import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Data.Conduit (($$), (=$), ($=), (=$=), ResourceIO, Source, Sink, SinkResult(..), Conduit, runResourceT, sinkIO)
import Data.Conduit.Binary (sourceHandle)
import Data.Conduit.Text (decode, utf8)
import Network.HTTP.Types (headerContentType, statusOK, statusNotFound)
import Network.Wai (Application, Request(..), Response(..), responseLBS)
import Network.Wai.EventSource (ServerEvent(..), eventSourceApp)
import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsHost, settingsPort)
import System.Console.CmdArgs
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import Text.Hamlet (Html, shamlet)
import qualified Data.Conduit.List as CL

main :: IO ()
main = do
  HtmlCat {..} <- cmdArgs htmlCat
  port <- newPort _port
  let url = "http://" ++ _host ++ ":" ++ show port
  putStrLn url
  whenJust _exec $ \exec ->
    forkIO $ void $ rawSystem exec [url]
  chan <- newChan
  runSettings (defaultSettings { settingsHost = _host
                               , settingsPort = port })
              (app chan)
  where
    whenJust = forM_

newPort :: Maybe Int -> IO Int
newPort port'm = foldr tryListening
                       (error "no available port")
                       (maybeToList port'm ++ [45192..60000])
  where
    tryListening p next = do
      r <- try . listenOn $ PortNumber (fromIntegral p)
      case r of
        Left (_ :: IOException) -> next
        Right sock -> do
          sClose sock
          return p

app :: Chan ServerEvent -> Application
app chan req =
  case pathInfo req of
    []         -> appTop req
    ["stream"] -> appStream chan req
    _          -> app404 req

appTop :: Application
appTop _ = return $
  ResponseBuilder statusOK
                  [headerContentType "text/html; charset=utf-8"]
                  (renderHtmlBuilder html)

appStream :: Chan ServerEvent -> Application
appStream chan req = do
  lift . void . forkIO . runResourceT $
    sourceStdIn $$ (lines =$= textsToEventSource) =$ sinkChan chan
  eventSourceApp chan req

app404 :: Application
app404 _ = return $ responseLBS statusNotFound [] "Not found"

sourceStdIn :: ResourceIO m => Source m Text
sourceStdIn = sourceHandle stdin $= decode utf8

lines :: Monad m => Conduit Text m [Text]
lines = CL.map T.lines

textsToEventSource :: Monad m => Conduit [Text] m ServerEvent
textsToEventSource = CL.map f
  where
    f texts = ServerEvent { eventName = Nothing
                          , eventId   = Nothing
                          , eventData = map fromText texts }

sinkChan :: ResourceIO m => Chan a -> Sink a m ()
sinkChan chan = sinkIO noop (const noop) push return
  where
    noop = return ()
    push _ a = do
      liftIO $ writeChan chan a
      return Processing

data HtmlCat = HtmlCat
  { _port :: Maybe Int
  , _host :: String
  , _exec :: Maybe String
  } deriving (Show, Data, Typeable)

htmlCat :: HtmlCat
htmlCat = HtmlCat
  { _port = Nothing     &= explicit &= name "port"
  , _host = "127.0.0.1" &= explicit &= name "host"
  , _exec = Nothing     &= explicit &= name "exec"
  }

html :: Html
html = [shamlet|
!!!
<html>
  <head>
    <title>htmlcat
    <script type="text/javascript">
      window.onload = function () {
        var es = new EventSource("/stream");
        es.onmessage = function(event) {
          var data = {};
          data.html = event.data;
          if (!data.html) {
            return;
          }
      
          if (window.scrollY + document.documentElement.clientHeight >= document.documentElement.scrollHeight) {
            var scrollToBottom = true;
          }
  
          var div = document.createElement('div');
          div.innerHTML = data.html + "\n";
  
          var out = document.getElementById('out');
          while (div.firstChild) {
            out.appendChild(div.firstChild);
          }
  
          document.title = data.html.replace(/<.*?>/g, '') + ' - htmlcat';
  
          if (scrollToBottom) {
            window.scrollTo(0, document.body.scrollHeight);
          }
        };
      };
  <body>
    <pre id="out">
|]

cloneしてcabal installすればhtmlcatコマンドが使えるようになります。

  • 色付け
  • --execオプション

はまだ実装してません。

Haskellでもserver-sent evnetsなどのpush技術は普通に使えますというデモでした。

追記

コマンドラインオプションを追加しました。

  • --execでコマンド実行。引数にURLを渡す。
  • --hostでリッスンするアドレスを指定。
  • --portでリッスンするポートを指定。

色づけは大変そうな気がするので、気が向いた方は実装してpullリクエスト送ってください。

追記

入力が複数行の時バグってたのを直しました。上のコードも差し替えました。

モナドトランスフォーマーとmonad-control

アドベントカレンダーのいいネタが無いなあと思っていたところ、ちょうど週末にあたらしいmonad-controlがリリースされたので、これを紹介したいなと思いました。

その前に、モナドトランスフォーマーというかっこいい名前の代物の話をちょっとだけしましょう。

モナドトランスフォーマーと例外処理

Haskellerの皆さんはきっと息をするかのように自然にモナドを使っていることと思います。標準で提供されているモナドは単機能なので、組み合わせたくなってきます。必然的に皆モナドトランスフォーマーに手を伸ばすわけです。実際のアプリケーションのコードを書くと、多くのモナドではベースモナドがIOになるでしょうから、今度は自作したカスタムモナドスタックでIOが投げる例外をハンドルしたくなるわけです。

ここでふとControl.Exception.catchの型をみると

Prelude> :t Control.Exception.catch
Control.Exception.catch
  :: Exception e => IO a -> (e -> IO a) -> IO a

catchに渡すアクションはIO aで、例外ハンドラはException e => e -> IO aという型です。

一方あなたの書いたアプリケーションは例えばこんな感じになっていることでしょう。

newtype MyAppT m a = MyAppT { runMyAppT :: StateT MyAppState (ReaderT MyAppEnv m) a }
  deriving (Functor, Applicative, Monad, MonadIO, ...)

runMyApp :: Monad m => MyAppT m a -> MyAppState -> MyAppEnv -> m a
runMyApp act st = runReaderT (runStateT (runMyAppT act) st)

app :: MonadIO m => MyAppT m a
app = do
  liftIO $ putStrLn "Hello, MyApp!"
  ...

main :: IO ()
main = do
  env <- setupMyAppEnv -- getArgsなどして必要な環境を作る
  runMyApp app initialMyAppState env -- 初期状態と一緒に渡してappを走らせる

このアプリ内で例外を扱いたい場合、catchの型は

catch :: Exception e => IO a -> (e -> IO a) -> IO a

ではなく

catch :: (Exception e, MonadIO m) => MyAppT m a -> (e -> MyAppT m a) -> MyAppT m a

より一般的には

catch :: (Exception e, MonadIO m) => m a -> (e -> m a) -> m a

みたいな一般的な型になっていると便利です。これを統一的に扱う仕組みがmonad-controlというわけです。

monad-control

最新のmonad-controlでは主要なパッケージが3つに分かれています。

  • monad-controlパッケージ
    • MonadTransControlクラスとMonadBaseControlクラスおよびそれらのインスタンスを提供
  • transformers-baseパッケージ
    • MonadBaseControlクラスの親となるMonadBaseクラスとそのインスタンスを提供
  • lifted-baseパッケージ
    • Control.ExceptionやControl.ConcurrentあるいはSystem.Timeoutの関数をmonad-controlで一般化した関数を提供

先の例に適用するとこんな感じになります。

newtype MyAppT m a = MyAppT
  { runMyAppT :: ReaderT MyAppEnv (StateT MyAppState m) a
  } deriving ( Functor
             , Applicative
             , Monad
             , MonadIO
             , MonadState MyAppState
             , MonadReader MyAppEnv
             , MonadBase base
             )

instance MonadTrans MyAppT where
  lift = MyAppT . lift . lift

instance MonadTransControl MyAppT where
  newtype StT MyAppT a = StMyApp { unStMyApp :: (a, MyAppState) }
  liftWith f = MyAppT . ReaderT $ \r -> StateT $ \s ->
    liftM (\x -> (x, s))
          (f $ \t -> liftM StMyApp
            (runStateT (runReaderT (runMyAppT t) r) s))
  restoreT = MyAppT . ReaderT . const . StateT . const . liftM unStMyApp

instance MonadBaseControl base m => MonadBaseControl base (MyAppT m) where
  newtype StM (MyAppT m) a = StMMyAppT { unStMMyAppT :: ComposeSt MyAppT m a }
  liftBaseWith = defaultLiftBaseWith StMMyAppT
  restoreM = defaultRestoreM unStMMyAppT

どうしてこれでうまくいくかは、MonadTransControlのIdentityTに対するインスタンスと、上のコードをじっくり読めばわかります。

簡単に解説すると、MonadTransControlクラスのliftWith :: Monad m => (Run t -> m a) -> t m aはモナドスタックt m aを一つpopした型m aを弄れるようにする役割を持ち、MonadBaseControlのliftBaseWith :: (RunInBase m b -> b a) -> m aは、スタックの最下部までpopしたベースモナドの型b aを弄れるようにする役割を持っています。デフォルトではMonadBaseControlの関数はMonadTransControlの関数を使って定義するので、自作のモナドトランスフォーマーは両方のインスタンスを定義してあげましょう。

これで準備は整いました。lifted-baseを使うと先のコードで上げられた例外を、MyAppT m aの中で綺麗にキャッチできるようになりました。めでたしめでたし。

import Control.Exception.Lifted (catch)

-- この例を実際に書くときはbracketを使おう
app :: MonadIO m => MyAppT m ()
app = do
  liftIO $ putStrLn "Hello, MyApp!"
  liftIO $ do
        h <- openFile "/home/maoe/NoSuchFile" ReadMode
        hGetContents h
        hClose h
    `catch` \(e :: SomeException) -> putStrLn $ "Caught " ++ show e

参考リンク

  • モナドトランスフォーマーの使い方
  • monad-control
    • 面倒になって端折ってしまった導入の動機付けとカラクリはmonad-controlに丁寧に解説されています。
      • ただし想定しているmonad-controlが古いインタフェースなので、実際のコードを書くときは上のコードを参考にすると良いと思います。

函数プログラミングの集いに参加してきました

毎年、OCamlミーティングというイベントが開催されているそうなのですが、今年はICFPが東京で開かれることもあり、OCamlに限らない関数プログラミングのお祭りとして開催された「函数プログラミングの集い」に参加してきました。

参加者の使用言語の分布が知りたかったので、イベント当日にアンケートを採りました。180人程度の参加者のうち73人の方に協力していただきました。ありがとうございました。

気になる結果はというと、こんなふうになりました。

やはりHaskellユーザが多かったようです。

個人的に面白かったところは

  • tanakhさんのモナドチュートリアルが実践的で良かった
  • SML#とCの相互運用性の高さに驚いた
  • OCamlのモジュールについて勉強したいなと思った

などなどでした。

発表の資料は函数プログラミングの集い2011にまとまっています。ちょっと長すぎてみる気が起きませんが、Togetterまとめもあるようです。

最近のHaskellマップ

函数プログラミングの集い、Language update Haskell編の発表資料です。

資料にはいろいろ書いてありますが、大事なことはひとつ、Hugsは死んだと言うことです。

HakyllでGitHubのProject PagesのHTMLを作る

GitHub PagesはJekyllが使えるので素直にRubyの流儀に従えばいいのですが、Haskell使いならやはりHakyllを使いたくなります。HakyllはテンプレートにYesodで使われているhamletも使えるので、Yesod使いならなおさらです。というわけでHakyll + GitHub Pagesのメモです。

まずは公式ドキュメントに沿ってgh-pagesブランチを作ります。

$ cd /path/to/fancypants
$ git symbolic-ref HEAD refs/heads/gh-pages
$ rm .git/index
$ git clean -fdx

...

$ echo "My GitHub Page" > index.html
$ git add .
$ git commit -a -m "First pages commit"
$ git push origin gh-pages
GitHub Pages

続いてHakyll用のファイルを準備します。gh-pages.hsとでもしておきましょう。

{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Category ((>>>))
import Hakyll

main :: IO ()
main = hakyllWith config $ do
  match "templates/*" $ compile templateCompiler
  match (list ["index.markdown"]) $ do
    route $ setExtension "html"
    compile $ pageCompiler
      >>> applyTemplateCompiler "templates/default.hamlet"
      >>> relativizeUrlsCompiler

config :: HakyllConfiguration
config = defaultHakyllConfiguration { deployCommand = deploy }
  where deploy = "cp -r _site/* . && runghc gh-pages.hs clean"

あとはtemplates/default.hamletと

!!!
<head>
  <meta charset=utf-8 />
  <title>#{title}
<body>
  #{body}

中身であるindex.markdownを作ります。

---
title: TKYProf - Home
---

TKYProf
================
A web-based interactive visualizer for GHC time and allocation profiling reports. It helps you find the performance bottlenecks of your code quickly.

How to use TKYProf
----------------
* `cabal install tkyprof` installs the executable `tkyprof`.
* Run `tkyprof` on your terminal.
* Access [http://localhost:3000/](http://localhost:3000/).
* Drag and drop your profiling reports. TKYProf also supports an ordinary file selection dialog.
* TKYProf redirects you to a pretty chart.

HTMLを生成してみましょう。

% runhaskell gh-pages.hs build
Initialising
  [   0ms] Creating store
  [   4ms] Creating provider
Adding new compilers
Compiling templates/default.hamlet
  [      ] Checking cache: modified
  [   1ms] Total compile time
Compiling index.markdown
  [      ] Checking cache: modified
  [   8ms] Total compile time
  [   0ms] Routing to index.html

buildではなくpreviewするとブラウザからHTMLを確認できます。

% runhaskell gh-pages.hs preview
LInitialising
  [   0ms] Creating store
istening on http://0.0.0.0:8000  [   7ms] Creating provider
Adding new compilers
/

問題ないことが確認できたらdeployコマンドを実行して、_siteディレクトリの中身をプロジェクトルートにコピーします。

% runhaskell gh-pages.hs deploy
Removing _site...
Removing _cache...

準備は整いました。生成されたファイルをcommitして、リモートのgh-pagesブランチにpushすればおしまいです。

TKYProf - Home