Extending Query, Relational, Typeful, Composable

Haskell Advent Calendar 2013 の19日目のエントリーです。

HaskellSQL の複雑な検索式を記述するための、Relational Record というライブラリ(以下HRR)(https://github.com/khibino/haskell-relational-record) を作ったので紹介します。このライブラリを使うことで、検索式を部品化し、単純な検索式を組合せて、より複雑な検索式を組み立てることができます。

HRR は HaskellDB (http://hackage.haskell.org/package/haskelldb) を参考にした関係代数ベースのライブラリですが、カラム名の問題、外部結合、集約操作、Placeholderの問題点を克服する形で再構成しました。以下に順番に説明していきたいと思います。

結合について

SQLの結合における問題

この話の性質上、まずは SQL をそのまま利用した場合の問題について説明したいと思います。

たとえば以下のようなレコードを持つテーブルを考えてみましょう。

テーブル名 user

data User = User {
 userId   :: Int    -- user_id
 userName :: String -- user_name
}

テーブル名 group

data Group = Group {
 groupId   :: Int    -- group_id
 groupName :: String -- group_name
}

テーブル名 membership

data Membership = Membership {
 uid :: Int    -- uid
 gid :: Int    -- gid
}

それぞれユーザーの一覧とグループの一覧、グループのメンバーを表現しているとします。

これらのテーブルの上でメンバーのユーザー名とグループ名を全て出力するような結合クエリを考えれば、次のようになるでしょう。

SQL - user と group - 名前のみ

SELECT user_name, group_name
FROM   (user INNER JOIN membership ON user_id = uid)
       INNER JOIN group ON group_id = gid

クエリはテーブル式でもあるので、クエリをさらに結合することができます。

ユーザーにさらに親子関係があるようなケースを考えてみましょう。親のユーザーを parentId で指定するとします。

テーブル名 user - 親ID付き

data User = User {
 userId   :: Int    -- user_id
 userName :: String -- user_name
 parentId :: Int    -- parent_id
}

親子関係を使って結合したいので、先程のクエリを変更します。

SQL - user と group - 親ID付き

SELECT user_name, group_name, user_id, parent_id
FROM   (user INNER JOIN membership ON user_id = uid)
       INNER JOIN group ON group_id = gid

これを親子関係で自身に結合すると次のようになるでしょう。カラム名に重複があるのでテーブルのエイリアス名を使って修飾します。

SQL - user と group の親子結合

SELECT P.user_name, P.group_name,
       C.user_name, C.group_name
FROM
 (SELECT user_name, group_name, user_id, parent_id
  FROM   (user INNER JOIN membership ON user_id = uid)
         INNER JOIN group ON group_id = gid) AS P
 INNER JOIN
 (SELECT user_name, group_name, user_id, parent_id
  FROM   (user INNER JOIN membership ON user_id = uid)
         INNER JOIN group ON group_id = gid) AS C
 ON    P.parent_id = C.user_id

同じ userとgroup の結合クエリを複数回書かなければならない問題があります*1が、この結合クエリを実行して、プログラムから結果を使うのならこれはこれで問題ありません。

しかし、さらにこのクエリを結合に使いたくなったと考えたらどうでしょうか。

P.user_name や C.user_name はこのクエリ内ではカラム名が区別されますが、このクエリの外側から見た場合には同じ名前になってしまって名前が衝突します。このようなケースではカラム名をつけかえることになります。

SQL - user と group の親子結合 - 名前つけかえ

SELECT P.user_name as parent_uid, P.group_name as parent_gid,
       C.user_name as child_uid,  C.group_name as child_gid
FROM
 (SELECT user_name, group_name, user_id, parent_id
  FROM   (user INNER JOIN membership ON user_id = uid)
         INNER JOIN group ON group_id = gid) AS P
 INNER JOIN
 (SELECT user_name, group_name, user_id, parent_id
  FROM   (user INNER JOIN membership ON user_id = uid)
         INNER JOIN group ON group_id = gid) AS C
 ON    P.parent_id = C.user_id

すべてのクエリを結合の一部として再利用可能になるようにしておくことを考えると、この名前のつけかえは結合を行なうたびに行なう必要があることになります。このつけかえの手間は SQL の名前付けの戦略の都合によるもので本来は必要のないはずのものです。結合式を部品化しながら複雑な結合を組み上げていく際に結合しやすさを損なう原因となります。

SQLの結合における問題 - 問題点のまとめ
  • 同じクエリを再利用するときに SQL文字列をコピーする必要がある問題
  • クエリを結合するときにカラム名をつけかえる必要がある問題
HRR による結合

準備として必要な定義を import します。

HRR の各種コンビネータは以下で import できます。クエリを書いていくにはそれ以外にテーブル定義の読み込みが必要です。

user と group - 名前のみ

import Database.Relational.Query

それでは、HRR がSQLの結合における2つの問題をどのように解決するか見ていきます。まずは素直に user と group の結合を書いてみると以下のようになります。

user と group - 名前のみ

userAndGroup' :: Relation () (String, String)
userAndGroup' =  relation $ do
  u <- query user
  m <- query membership

  on $ u ! userId'  .=. m ! uid'

  g <- query group

  on $ g ! groupId' .=. m ! gid'

  return $ u ! userName' >< g ! groupName'

{-
 SELECT T0.user_name AS f0, T2.group_name AS f1
 FROM (EXAMPLE.user T0 INNER JOIN
       EXAMPLE.membership T1
       ON (T0.user_id = T1.uid))
       INNER JOIN EXAMPLE.group T2
       ON (T2.group_id = T1.gid)
 -}

HRR では Relation という型のクエリの式を書いておくと、それを SQL に変換することができます。

たとえば上の userAndGroup' はコメント内にあるような SQL に変換されます。query で結合に加えるテーブル式を指定し、on で結合条件を指定しています。
(!) は第1引数にレコード、第2引数にキーを受け取ってカラムを選択しています。(.=.)は SQL の = です。(><) で並べることでタプルの結果を作ることができます。

今回の例では親子関係で結合しようとしているので、結果のカラム選択を行なわずにレコードを取り出すことにしましょう。

user と group

userAndGroup :: Relation () (User, Group)
userAndGroup =  relation $ do
  u <- query user
  m <- query membership

  on $ u ! userId'  .=. m ! uid'

  g <- query group

  on $ g ! groupId' .=. m ! gid'

  return $ u >< g

{-
 SELECT T0.user_id AS f0, T0.user_name AS f1, T0.parent_id AS f2,
        T2.group_id AS f3, T2.group_name AS f4
 FROM (EXAMPLE.user T0 INNER JOIN
       EXAMPLE.membership T1
       ON (T0.user_id = T1.uid))
       INNER JOIN EXAMPLE.group T2 ON (T2.group_id = T1.gid)
 -}

レコードの型と SQL の値の並びを対応付けることでこのような機能を実現しています。レコードの型をそのまま利用することで記述がすっきりしました。

それではこちらでも親子関係で結合してみましょう。

user と group の親子結合 - カラム選択

parentAndChildOfUserGroups0
   :: Relation () ((String, String), (String, String))
parentAndChildOfUserGroups0 =  relation $ do
  parent <- query userAndGroup
  child  <- query userAndGroup

  on $ parent ! fst' ! parentId' .=. child ! fst' ! userId'

  return ((parent ! fst' ! userName' ><
           parent ! snd' ! groupName')
          ><
          (child ! fst' ! userName' ><
           child ! snd' ! groupName'))

{-
 SELECT T3.f1 AS f0, T3.f4 AS f1, T7.f1 AS f2, T7.f4 AS f3
 FROM (SELECT T0.user_id AS f0, T0.user_name AS f1, T0.parent_id AS f2,
              T2.group_id AS f3, T2.group_name AS f4
       FROM (EXAMPLE.user T0 INNER JOIN
             EXAMPLE.membership T1
             ON (T0.user_id = T1.uid)) INNER JOIN
            EXAMPLE.group T2 ON (T2.group_id = T1.gid)) T3 INNER JOIN
            (SELECT T4.user_id AS f0, T4.user_name AS f1,
                    T4.parent_id AS f2,
                    T6.group_id AS f3, T6.group_name AS f4
             FROM (EXAMPLE.user T4 INNER JOIN
                   EXAMPLE.membership T5
                   ON (T4.user_id = T5.uid)) INNER JOIN
                  EXAMPLE.group T6
                  ON (T6.group_id = T5.gid)) T7 ON (T3.f2 = T7.f0)
 -}

さきほど定義した userAndGroup をそのまま再利用して結合を行なっています。展開後の SQL 内の名前のつけかえも自動的の行なわれるので気にする必要はありません。またこのように定義した結合を含んだ Relation も、そのまま他の Relation から再利用することができます。
(!) が連なって使われいますが、これは (a, b) がカラム2つのレコードと考えるとわかりやすいです。fst' および snd' をキーとして指定すれば、それぞれ fst側、snd側を選択することができます。この例ではその選択されたレコードからさらにカラムを選択しています。

ところで、Relation の記述内の式は単なる Haskell の式なので、変数にも束縛できます。

user と group の親子結合 - let

parentAndChildOfUserGroups1
   :: Relation () ((String, String), (String, String))
parentAndChildOfUserGroups1 =  relation $ do
  parent <- query userAndGroup
  child  <- query userAndGroup

  let parentUser = parent ! fst'
      childUser  = child  ! fst'

  on $ parentUser ! parentId' .=. childUser ! userId'

  return ((parentUser ! userName' ><
           parent ! snd' ! groupName')
          ><
          (childUser  ! userName' ><
           child  ! snd' ! groupName'))

parentUser と childUser の部分を let で共通化することができました。

SQLは長くなりますが、レコードをそのまま取り出す方が記述は単純になります。

HRR - user と group の親子結合

parentAndChildOfUserGroups :: Relation () ((User, Group), (User, Group))
parentAndChildOfUserGroups =  relation $ do
  parent <- query userAndGroup
  child  <- query userAndGroup

  on $ parent ! fst' ! parentId' .=. child ! fst' ! userId'

  return $ parent >< child

余談ですが、Monad内包表記を使って書くと、より SQL っぽい語順になります。

HRR - user と group の親子結合 - Monad内包表記

parentAndChildOfUserGroupsMC :: Relation () ((User, Group), (User, Group))
parentAndChildOfUserGroupsMC =  relation
  [ parent >< child
    | parent <- query userAndGroup
    , child  <- query userAndGroup

    , () <- on $ parent ! fst' ! parentId' .=. child ! fst' ! userId'
    ]
HRR による結合 - まとめ
  • 定義済みのクエリを再利用してより大きなクエリを構成できる
  • カラムの名前つけかえが不要
  • レコードの型をそのまま扱える
外部結合と直接結合記法 - Outer join and Direct Join style

HRR は外部結合もサポートしています。さきほどのテーブルでグループに参加していないユーザーや参加者のいないグループも全て出力するクエリを考えていみます。

user と group - 外部結合

groupMemberShip :: Relation () (Maybe Membership, Group)
groupMemberShip =  relation $ do
  [ m >< g
    | m  <- queryMaybe membership
    , g  <- query      group
    , () <- on $ m ?! gid' .=. just (g ! groupId')
    ]

userAndGroupAll :: Relation () (Maybe User, Maybe Group)
userAndGroupAll =  relation $ do
  u  <- queryMaybe user
  mg <- queryMaybe groupMemberShip

  let mayM = mg ?!? fst'
  on $ u ?! userId' .=. mayM ?! uid'

  let g    = mg ?! snd'

  return $ u >< g

{-
 SELECT T0.user_id AS f0, T0.user_name AS f1, T0.parent_id AS f2,
        T3.f2 AS f3, T3.f3 AS f4
 FROM EXAMPLE.user T0 FULL JOIN
      (SELECT T1.uid AS f0, T1.gid AS f1,
              T2.group_id AS f2, T2.group_name AS f3
       FROM EXAMPLE.membership T1 RIGHT JOIN
            EXAMPLE.group T2
            ON (T1.gid = T2.group_id)) T3
      ON (T0.user_id = T3.f0)
 -}

外部結合で NULL(Haskell 側では Nothing) を許す側を query ではなく queryMaybe にします。型の中に Maybe が混ざるため、カラム選択や条件式で (?!)、(?!?)、just が出てきて面倒ですが、このようにすることで、結果の型へ Maybe を伝搬させることができます。

ここまでで紹介した結合の記述方法は結合に加えるテーブル式を query あるいは queryMaybe で指定していく方式でした。しかし、この記述方法では、そこまでに組みあげた結合の側に NULL を許すような外部結合を書くことができません。

そこで、直接結合の記法を紹介します。一つ前の Relation を直接結合の記法で書くと以下のようになります。

user と group - 外部結合

userAndGroupAllDirect :: Relation () (Maybe User, Maybe Group)
userAndGroupAllDirect = relation $ do
  umg <- query $
         (user `left` membership
          `on'` [\ u m -> just (u ! userId') .=. m ?! uid' ])
         `full`
         group
         `on'` [ \ um g -> um ?!? snd' ?! gid' .=. g ?! groupId' ]
  let um = umg ! fst'
      u  = um ?! fst'
      g  = umg ! snd'

  return $ u >< g

{-
 SELECT T4.f0 AS f0, T4.f1 AS f1, T4.f2 AS f2, T4.f5 AS f3, T4.f6 AS f4
 FROM (SELECT T2.f0 AS f0, T2.f1 AS f1, T2.f2 AS f2,
              T2.f3 AS f3, T2.f4 AS f4,
              T3.group_id AS f5, T3.group_name AS f6
       FROM (SELECT T0.user_id AS f0, T0.user_name AS f1,
                    T0.parent_id AS f2, T1.uid AS f3, T1.gid AS f4
             FROM EXAMPLE.user T0 LEFT JOIN
                  EXAMPLE.membership T1
                  ON (T0.user_id = T1.uid)) T2 FULL JOIN
                  EXAMPLE.group T3
                  ON (T2.f4 = T3.group_id)) T4
 -}

left、full がそれぞれ LEFT JOIN、FULL JOIN のための2項演算です。on' に条件式を返すラムダ式のリスト渡すことで結合条件を指定します。

様々な型付け

SQL の集約操作と型付け

次は集約操作を行なう例を考えてみましょう。次の SQL はグループのメンバーが 3人以上いるグループを並べ挙げています。

SQL - グループで集約

SELECT gid,
       ('gid 0以外の3人以上のグループ: ' || group_name),
       count (*)
FROM   group INNER JOIN membership ON group_id = gid
WHERE gid <> 0
GROUP BY gid, group_name
HAVING count (*) >= 3

集約を行なっているクエリの場合、SELECT と FROM の間に書く結果のカラムや HAVING 節の条件には集約しているキーと集約関数の式しか書くことができません。WHERE 節の条件に書ける式とは区別する必要があるのです。

HRR では型付けでこの区別を行なうので、誤った式を書かずに済みます。同じ意味を持つクエリを HRR で書けば次のようになります。

グループで集約

memberMoreThanTwo :: Relation () ((Int32, String), Int32)
memberMoreThanTwo = aggregateRelation $ do
  g <- query group
  m <- query membership

  let mgid = m ! gid'
  wheres $ mgid .>. value 0

  aggregatedGid       <- groupBy $ mgid
  aggregatedGroupName <- groupBy $ g ! groupName'

  let mcount = count (mgid)
  having $ mcount .>=. value 3

  return (aggregatedGid                           ><
          value "gid 0以外の3人以上のグループ: "
            .||. aggregatedGroupName              ><
          mcount {- >< u ! uid'  型エラーになる -} )

{-
 SELECT T1.gid AS f0,
        ('gid 0以外の3人以上のグループ: ' || T0.group_name) AS f1,
        COUNT (T1.gid) AS f2
 FROM EXAMPLE.group T0 INNER JOIN
      EXAMPLE.membership T1 ON (0=0)
 WHERE (T1.gid > 0)
 GROUP BY T1.gid, T0.group_name
 HAVING (COUNT (T1.gid) >= 3)
 -}

wheres で WHERE 節に指定する条件式と、having で HAVING節に指定する条件は型が区別されます。この例の場合では集約していないキー (たとえば u ! uid' 等) を間違って結果に含めてしまったり、HAVING 内に書いてしまったりということが起こりません。

また、このように集約を含んだ Relation も別の Relation の定義内から結合等に再利用することができます。

Ordrings

SQL の ORDER BY ... に指定する式においても、集約を行なっていない場合と行なっている場合で書ける式が変わってきます。集約している場合には集約しているキーと集約関数の式しか書くことができません。

HRR はこれについても集約の例で示したのと同様に型を区別することで誤りを防ぎます。

まずは集約していないものの例です。先に定義した userAndGroup に昇順の制約を加えたものが以下のようになります。 asc で昇順の制約とする式を指定しています。

user と group - 名前昇順

userAndGroupAsc :: Relation () (User, Group)
userAndGroupAsc =  relation $ do
  u <- query user
  m <- query membership

  on $ u ! userId'  .=. m ! uid'

  g <- query group

  on $ g ! groupId' .=. m ! gid'

  asc $ g ! groupName'
  asc $ u ! userName'

  return $ u >< g

{-
 SELECT T0.user_id AS f0, T0.user_name AS f1, T0.parent_id AS f2,
        T2.group_id AS f3, T2.group_name AS f4
 FROM (EXAMPLE.user T0 INNER JOIN
       EXAMPLE.membership T1
       ON (T0.user_id = T1.uid))
      INNER JOIN
      EXAMPLE.group T2
      ON (T2.group_id = T1.gid)
 ORDER BY T2.group_name ASC, T0.user_name ASC
 -}

次は集約している場合の例です。先に定義した memberMoreThanTwo に降順の制約を加えたものが以下のようになります。desc で昇順の制約とする式を指定しています。

user と group - 名前昇順

memberMoreThanTwoDesc :: Relation () ((Int32, String), Int32)
memberMoreThanTwoDesc =  aggregateRelation $ do
  g <- query group
  m <- query membership

  let mgid = m ! gid'
  wheres $ mgid .>. value 0

  aggregatedGid       <- groupBy   mgid
  aggregatedGroupName <- groupBy $ g ! groupName'

  let mcount = count (mgid)
  having $ mcount .>=. value 3

  desc mcount

  return (aggregatedGid                          ><
          value "gid 0以外の3人以上のグループ: "
            .||. aggregatedGroupName             ><
          mcount)

{-
 SELECT T1.gid AS f0,
        ('gid 0以外の3人以上のグループ: ' || T0.group_name) AS f1,
        COUNT (T1.gid) AS f2
 FROM EXAMPLE.group T0 INNER JOIN
      EXAMPLE.membership T1
      ON (0=0)
 WHERE (T1.gid > 0)
 GROUP BY T1.gid, T0.group_name
 HAVING (COUNT (T1.gid) >= 3)
 ORDER BY COUNT (T1.gid) DESC
 -}

ここでは desc には集約しているキーと集約関数の式しか指定できないように型が検査されます。

Placeholderの型付けと伝搬 - Typeful Placeholder propagation

placeholder についても型付けをしてみました。まずは例としてグループ名を Placeholder で指定するクエリを考えてみます。

group - place holder でグループ名指定

specifiedGroup :: Relation String Group
specifiedGroup =  relation' $ do
  g <- query group

  (ph, ()) <- placeholder (\ph' -> wheres $ g ! groupName' .=. ph')

  return (ph, g)

{-
 SELECT T0.group_id AS f0, T0.group_name AS f1
 FROM EXAMPLE.group T0
 WHERE (T0.group_name = ?)
 -}

Placeholder を使いたい式を placeholder で囲むと引数に Placeholder を貰うことができます。placeholder の結果は Placeholder の型を運ぶための変数と囲んだ式の結果のペアになります。ここでは wheres の中で Placeholder を使っています。

Placeholder の型を運ぶ変数をクエリの結果とともに relation' に渡すことで Placeholder の型付きの Relation を作ることができます。Placeholder の型は Relation の第一引数なので、ここでは Placeholder の型は String です。

次は Placeholder 付きの Relation を結合に利用する例です。

user と group - place holder でグループ名指定

userAndSpecifiedGroup :: Relation String (User, Group)
userAndSpecifiedGroup =  relation' $ do
  u <- query user
  m <- query membership

  on $ u ! userId'  .=. m ! uid'

  (ph, g) <- query' specifiedGroup

  on $ g ! groupId' .=. m ! gid'

  return (ph, u >< g)

{-
 SELECT T0.user_id AS f0, T0.user_name AS f1, T0.parent_id AS f2,
        T3.f0 AS f3, T3.f1 AS f4
 FROM (EXAMPLE.user T0 INNER JOIN
       EXAMPLE.membership T1
       ON (T0.user_id = T1.uid)) INNER JOIN
      (SELECT T2.group_id AS f0, T2.group_name AS f1
       FROM EXAMPLE.group T2
       WHERE (T2.group_name = ?)) T3
      ON (T3.f0 = T1.gid)
 -}

Placeholder 付きの Relation を結合に加えるときには query' あるいは queryMaybe' を使います。Placeholder を伝搬させるために relation' に渡すのは先程と同様です。

Placeholder が複数ある場合には (><) で融合して返すことができますが、順番には注意が必要です。直接結合の形式で書くと、この融合を同時に行なうことができて誤りを減らせます。

user と group の親子結合 - place holder でグループ名指定

parentAndChildOfuserSpecifiedGroups :: Relation
                                       (String, String)
                                       ((User, Group), (User, Group))
parentAndChildOfuserSpecifiedGroups =  relation' $
  query' (userAndSpecifiedGroup
          `inner'`
          userAndSpecifiedGroup
          `on'`
          [\ parent child -> parent ! fst' ! parentId' .=. child ! fst' ! userId' ])

inner' は 2つの Relation の結合を行なうとともに両側の Placeholder を融合してタプルの型の Phace holder にします。この例では、その融合した Placeholder と結合の結果のペアをそのまま relation' に渡しています。

複合キーと Placeholder - Composite key and Placeholders

HRR では複合キーを表現する値を定義できます。まずは単純な例を示してみましょう。

複合キー (1)

gidAndName :: Pi Group (Int32, String)
gidAndName =  groupId' >< groupName'

userAndGroupComposedKey :: Relation () (User, Group)
userAndGroupComposedKey =  relation $ do
  ug <- query userAndGroup
  wheres $ ug ! snd' ! gidAndName .=. value (1, "Kei Hibino")

  return ug

{-
 SELECT T3.f0 AS f0, T3.f1 AS f1, T3.f2 AS f2, T3.f3 AS f3, T3.f4 AS f4
 FROM (SELECT T0.user_id AS f0, T0.user_name AS f1, T0.parent_id AS f2,
              T2.group_id AS f3, T2.group_name AS f4
       FROM (EXAMPLE.user T0 INNER JOIN
             EXAMPLE.membership T1 ON (T0.user_id = T1.uid)) INNER JOIN
            EXAMPLE.group T2
            ON (T2.group_id = T1.gid)) T3
 WHERE ((T3.f3, T3.f4) = (1, 'Kei Hibino'))
 -}

gidAndName は groupId' と groupName' を (><) で融合した複合キーです。(><) はキーに限って考えれば次のような型で、キーを並べます。タプルの結果を選択することができるキーを作ります。

タプルを選択するキー

(><) :: Pi a b -> Pi a c -> Pi a (b, c)

Pi Group (Int32, String) という型は Group から (Int32, String) を選択するキーであるということを表現しています。複合キーを使うと、ug
! snd' ! gidAndName のように、複数の並んだ値をタプルの型で一度に選択できます。この例では一度に選択した値とタプルの定数値 value (1, "Kei Hibino") の比較をクエリの条件に書いています。

もう少し複雑なキーも作ってみましょう。

複合キー (2)

parentAndGroupName :: Pi ((User, Group), (User, Group)) (Int32, String)
parentAndGroupName =
  fst' <.> fst' <.> userId'
  ><
  snd' <.> snd' <.> groupName'

parentAndChildOfComposedKey :: Relation () ((User, Group), (User, Group))
parentAndChildOfComposedKey =  relation $ do
  pc <- query parentAndChildOfUserGroups
  wheres $ pc ! parentAndGroupName .=. value (1, "Haskell")

  return pc

{-
 SELECT T8.f0 AS f0, T8.f1 AS f1, T8.f2 AS f2, T8.f3 AS f3, T8.f4 AS f4,
        T8.f5 AS f5, T8.f6 AS f6, T8.f7 AS f7, T8.f8 AS f8, T8.f9 AS f9
 FROM (SELECT T3.f0 AS f0, T3.f1 AS f1, T3.f2 AS f2,
              T3.f3 AS f3, T3.f4 AS f4,
              T7.f0 AS f5, T7.f1 AS f6, T7.f2 AS f7,
              T7.f3 AS f8, T7.f4 AS f9
       FROM (SELECT T0.user_id AS f0, T0.user_name AS f1, T0.parent_id AS f2,
                    T2.group_id AS f3, T2.group_name AS f4
             FROM (EXAMPLE.user T0 INNER JOIN
                   EXAMPLE.membership T1
                   ON (T0.user_id = T1.uid)) INNER JOIN
                  EXAMPLE.group T2
                  ON (T2.group_id = T1.gid)) T3 INNER JOIN
                  (SELECT T4.user_id AS f0, T4.user_name AS f1,
                          T4.parent_id AS f2,
                          T6.group_id AS f3, T6.group_name AS f4
                   FROM (EXAMPLE.user T4 INNER JOIN
                         EXAMPLE.membership T5
                         ON (T4.user_id = T5.uid)) INNER JOIN
                        EXAMPLE.group T6
                        ON (T6.group_id = T5.gid)) T7
                        ON (T3.f2 = T7.f0)) T8
 WHERE ((T8.f0, T8.f9) = (1, 'Haskell'))
 -}

parentAndGroupName をよく見てみましょう。(<.>) は次のような型になっていてキーを継ぎ足します。一般的には (r ! k1) ! k2 == r ! (k1 <.> k2) が成り立ちます。

キーの継ぎ足し

(<.>) :: Pi a b -> Pi b c -> Pi a c

最後に継ぎ足したキー同士を (><) で融合しています。結果として、( (User, Group), (User, Group) ) から (Int32, String) を選択するキーが定義されています。parentAndGroupName は ( (User, Group), (User, Group) ) の fst側を親、snd側を子として、親のユーザーID子のグループ名で選択するキーを表現しています。

Placeholder は実は複合した値にも対応しています。

複合した値のPlaceholder

parentUserAndChildGroup :: Relation (Int32, String) ((User, Group), (User, Group))
parentUserAndChildGroup =  relation' $ do
  pc <- query parentAndChildOfUserGroups
  (ph, ()) <- placeholder (\ph' -> wheres $ pc ! parentAndGroupName .=. ph')

  return (ph, pc)

parentAndGroupName で選択した (Int32, String) の型を持つ placeholder を一つで表現できてきます。
この機能を活用することで、placeholder の順番の誤りを減らすことができるでしょう。

対応RDBMS

HRR はテーブル定義を読み取るところのみ、RDBMS に依存しています。現状でテーブル定義読み取りに対応しているデータベースは IBM DB2, PostgreSQL, Microsoft SQL server, SQLite3, Oracle です。 Microsoft SQL server, SQLite3 の対応 (https://github.com/yuga/haskell-relational-record-driver-sqlserver, https://github.com/yuga/haskell-relational-record-driver-sqlite3)は @yuga さんから、Oracle 対応 (https://github.com/amutake/haskell-relational-record-driver-oracle)は @amutake_s さんから contribute をいただきました。ありがとうございます。

まとめ

クエリの記述方法にしぼって、SQL を安全に Composable に組み立てるライブラリ Haskell Relational Record (https://github.com/khibino/haskell-relational-record) を紹介しました。複雑な SQL を書かざるをえない Haskeller の助けになれば幸いです。また問題点や提案、類似ツールの紹介などありましたら、教えていただけると私が喜びます。

*1:VIEW を使えば良いという意見もありそうですが

HaskellDB と Template Haskell

Haskell Advent Calendar 2012の6日目のエントリです。

今回は複雑な SQL Queryを型安全に書くためのライブラリ HaskellDB を紹介します。

Queryの記述例

さっそくですが簡単な Query を HaskellDB で書いてみます。

簡単のために疑似コードにしてありますが、以下ような型のフィールド名を持つテーブルを2つ考えてみます。

Password.hs

-- password -- テーブル名
-- userName :: String
-- uid :: Int
-- gid :: Int

Group.hs

-- group -- テーブル名
-- groupName :: String
-- gid :: Int

まずは細かいことを気にせずに Query の記述の気分を体験してみましょう。

必要な定義が揃っていれば、以下の queryRoot のように Query を書くことができます。

sample.hs

import Password (Password, password)
import Database.HaskellDB
  (Query, Select, Rel,
  table, restrict, (!), (.==.), constant)

queryRoot :: Query (Rel Password)
queryRoot =  do
  pwd <- table password
  restrict $ pwd ! Password.uid .==. constant 0
  return pwd

-- 展開結果のSQL
-- SELECT user_name,
--        uid,
--        gid
-- FROM SCHEMA0.password as T1
-- WHERE uid = 0

table で定義済のテーブル password からテーブルで表現される関係の Query を作り、restrict で条件を記述しています。
Query 型は Show の instance にもなっていて、結果としてどのような SQL に展開されるかを文字列で取り出すこともできます。
queryRoot の SQL への展開結果は以上のコメント部分に書いてみました。

つぎに結合した式も書いてみましょう(queryJoin0)。

sample1.hs

import Password (password)
import Group (group)
import Database.HaskellDB
  (Query, Select,
  table, restrict, project, (!), (.==.), (#), (<<),
  constant)

queryJoin0 = do
  pwd <- table password
  grp <- table group
  restrict $ pwd ! Password.gid .==. grp ! Group.gid
  project (Password.uid       <<  pwd ! Password.uid       #
           Password.userName  <<  pwd ! Password.userName  #
           Group.groupName    <<  grp ! Group.groupName    )

-- 展開結果のSQL
-- SELECT uid1 as uid,
--        user_name1 as user_name,
--        group_name2 as group_name
-- FROM (SELECT group_name as group_name2,
--              gid as gid2
--       FROM SCHEMA0.group as T1) as T1,
--      (SELECT user_name as user_name1,
--              uid as uid1,
--              gid as gid1
--       FROM SCHEMA0.password as T1) as T2
-- WHERE gid1 = gid2

Query を do の中に並べることで関係の結合の Query を表現することができます。
ここではテーブル password と group で表現される関係の直積の Query を記述し、restrict で gid が一致するものだけに制限しています。
do の最後の式の project は、結合した結果から取り出すフィールドを選択しています。

以上のように、型検査された代数的な結合式の定義から、SQLの結合式を生成することができました。

Query を定義することで結合式を部品化することになるので、別の結合式の一部として再利用することができます。
以下はあまりおもしろくない例ですが、queryJoin0 を再利用してより大きな結合式を記述しています。

sample1a.hs

queryJoin1 = do
  j0  <- queryJoin0
  pwd <- table password
  restrict $ j0 ! Password.uid .<. pwd ! Password.uid
  project (nameA   << j0  ! Password.name #
           nameB   << pwd ! Password.name )

-- 展開結果のSQL
-- SELECT name3 as name_a,
--        name4 as name_b
-- FROM (SELECT name as name4,
--              uid as uid4
--       FROM PUBLIC.password as T1) as T1,
--      (SELECT uid1 as uid3,
--              name1 as name3,
--              name2 as name3
--       FROM (SELECT name as name2,
--                    gid as gid2
--             FROM PUBLIC.group as T1) as T1,
--            (SELECT name as name1,
--                    uid as uid1,
--                    gid as gid1
--             FROM PUBLIC.password as T1) as T2
--       WHERE gid1 = gid2) as T2

文字列で直接 SQL を書くときとは違って、細かい文法の間違いや暗黙の型変換が起こることはありません。Haskell で型を検査しながら安全に複雑な Query を書くことができます。
また、そのように定義した Query を複数箇所で再利用してより大きなQueryを記述できるのも、直接 SQL を書く場合に比べた利点です。

HaskellDBを利用するときに必要な定義

HaskellDB はすばらしいライブラリですが、利用するための定義の記述が面倒です。

HaskellDB でテーブルに対する Query を記述するには、対象のテーブルを定義しておく必要があります。
また、Query 結果である関係にフィールドの値による制限を付加するにはフィールドを表現する式と型を定義しておく必要があります。

テーブルは以下のように定義します。
テーブルの定義(以下の例ではgroup)は table で Query を表現するのに必要となります。

Group.hs

-- 関係の型の定義
type Group = RecCons GroupName (Expr String) (RecCons Gid (Expr Int) RecNil)
-- テーブルの定義
group :: Table Group
group =  baseTable
          "SCHEMA0.group"
          ((hdbMakeEntry GroupName) # (hdbMakeEntry Gid))

フィールドを表現する式と型は以下のように書きます。
フィールドの定義(以下の例ではgroupName)は、関係から特定のフィールドを指定したり、Query を実行した結果であるレコードから値を取り出すために使います。フィールドの定義の型を FieldTag のインスタンンスにすることで SQL におけるフィールド名を指定しています。

Group.hs

data GroupName = GroupName
instance FieldTag GroupName where
  fieldName _ = "group_name"

groupName :: Attr GroupName String
groupName = mkAttr GroupName

このような定義がフィールドごと必要となり大変です。

Template Haskellによる定義

フィールドの名前と型のリストから、
テーブルやフィールドを表現する式を Template Haskell で生成するとスマートです。

以下の例では mkRelationType ではフィールドの名前と型のリストからテーブルの型と値を定義する Haskell の式を組みたてています。
defineFieldExpr でフィールドを表現する式の定義を組みたて、defineFieldType でフィールドを表現する式の型の定義とその FieldTag のインスタンスを定義する式を組みたてています。

TH.hs

mkRelationType :: [(Name, TH.TypeQ)] -> TH.TypeQ
mkRelationType =  foldr (\(n,e) exp' -> [t|RecCons $(conT n) (Expr $e) $exp'|]) [t|RecNil|]

defineFieldExpr attrName ypeName typeQ = do
  -- フィールドの表現の型シグネチャ
  fieldS <- sigD attrName [t|Attr $(conT typeName) $typeQ|]
  -- フィールドの表現
  fieldF <- valD (varP attrName) (normalB [|mkAttr $(conE typeName)|]) []

  return [fieldS, fieldF]

defineFieldType typeName colName = do
  fieldD <- dataD (cxt []) typeName [] [normalC typeName []] []
  fieldI <- [d| instance FieldTag $(conT typeName) where
                  fieldName _ = $(litE (stringL colName)) |]
  return $ fieldD : fieldI

Template Haskell は便利なのですが、GHC のバージョンアップによって互換性が壊れやすいと言われています。

次の2つに注意して書くと良いと私は考えています。

  • Haskellの文法が変わることは少ないはずなので、できるだけ Quote ([| |], [t| |], [d| |], [p| |]) を使って書く
  • データコンストラクタ (AppE等) を使って書くと Template Haskell のデータ定義に強く依存してしまうので、Q Monad を生成する関数 (appE等) を使って書く

ライブラリにしてみた

HaskellDB まわりのよく使いそうな定義を Template Haskell を使って生成するライブラリを作ってみました。

https://github.com/khibino/haskelldb-genschema

まとめ

  • HaskellDB は複雑な SQL Query を安全に書くのに便利
  • しかし Queryを書くのに必要な定義が多くて準備が面倒
  • 定義を Template Haskell で生成するライブラリを書いてみました

GHCi debugger を使ってみた

Haskell Advent Calendar 2011 のためのエントリです。

最近、会社でも Haskell を開発のメンバーで使っていくことに正式に決まりました。

Haskell のプログラムをデバッグするときにデバッガーのようなツールを使うことが
できるのか社内で質問されたので調べてみました。

GHCi debugger

公式のドキュメント
http://www.haskell.org/ghc/docs/7.0.4/html/users_guide/ghci-debugger.html

その翻訳
http://www.kotha.net/ghcguide_ja/7.0.4/ghci-debugger.html
参考にしながら試してみて、私なりに理解した内容を紹介しようと思います。 mkothaさん、すばらしい翻訳をありがとうございます。


さっそく、GHCi debugger を使ってみましょう。
GHCi debugger は対話環境である GHCi に組込まれている debugger です。
まずプログラムを GHCi に読み込みます。
例えば、以下のような階乗を計算するプログラムを例にとってみましょう。

factorial.hs

factorial 0 = 1
factorial n = n * factorial (n - 1)

main = print (factorial 20)
% ghci factorial.hs
GHCi, version 7.0.4: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
[1 of 1] Compiling Main             ( factorial.hs, interpreted )
Ok, modules loaded: Main.
*Main>

ブレークポイント - :break

ブレークポイントを設定してみます。
ブレークポイントを設定するには GHCi のコマンドである :break を使います。
コマンドは短く省略できるようになっているらしく、:b でも良いようです。
引数に関数名を指定しています。

:show breaks で、設定したブレークポイントを確認することができます。
ブレークポイントには番号が振られるようです。ここでは 0 ですね。

*Main> :b factorial
Breakpoint 0 activated at factorial.hs:(1,1)-(2,35)
*Main> :break factorial
Breakpoint 0 was already set at factorial.hs:(1,1)-(2,35)
*Main> :show breaks
[0] Main factorial.hs:(1,1)-(2,35)
*Main>

以下の様に実行してみるとブレークポイントで止まります。
止まった箇所のソースコード:list で確認することができます。
vv と ^^ で次に実行する箇所を範囲で示しているようです。
factorial をブレークポイントに設定したので、
呼び出しの直前で停止しています。

*Main> main
Stopped at factorial.hs:(1,1)-(2,35)
_result :: a = _
[factorial.hs:(1,1)-(2,35)] *Main> :list
   vv
1  factorial 0 = 1
2  factorial n = n * factorial (n - 1)
                                      ^^
3  
[factorial.hs:(1,1)-(2,35)] *Main>

ステップ実行と自由変数 - :step, :print

これだけではおもしろくもないので、
関数の中へステップ実行してみることにします。
今度は ^^^ で次の実行箇所が示されています。

ここでは自由変数 n があるのでその値を覗き見することができます。
:step の直後に

n :: Integer = 20

と表示されているのがそうです。

[factorial.hs:(1,1)-(2,35)] *Main> :step
Stopped at factorial.hs:2:15-35
_result :: Integer = _
n :: Integer = 20
[factorial.hs:2:15-35] *Main> :list
1  factorial 0 = 1
2  factorial n = n * factorial (n - 1)
                 ^^^^^^^^^^^^^^^^^^^^^
3  
[factorial.hs:2:15-35] *Main>

明示的に表示させる :print というコマンドもあります。

[factorial.hs:2:15-35] *Main> :print n
n = 20
[factorial.hs:2:15-35] *Main> :p n
n = 20
[factorial.hs:2:15-35] *Main>

:set stop コマンドで
止まったときに実行するコマンドを設定することもできます。
ここでは :list を実行するようにしてみましょう。
そして、いくつかステップを進めてみます。

[factorial.hs:2:15-35] *Main> :set stop :list
[factorial.hs:2:15-35] *Main> :st
Stopped at factorial.hs:2:19-35
_result :: Integer = _
n :: Integer = 20
1  factorial 0 = 1
2  factorial n = n * factorial (n - 1)
                     ^^^^^^^^^^^^^^^^^
3  
[factorial.hs:2:19-35] *Main> :st
Stopped at factorial.hs:(1,1)-(2,35)
_result :: a = _
   vv
1  factorial 0 = 1
2  factorial n = n * factorial (n - 1)
                                      ^^
3  
[factorial.hs:(1,1)-(2,35)] *Main> :st
Stopped at factorial.hs:2:30-34
_result :: Integer = _
n :: Integer = 20
1  factorial 0 = 1
2  factorial n = n * factorial (n - 1)
                                ^^^^^
3  
[factorial.hs:2:30-34] *Main> :st
Stopped at factorial.hs:2:15-35
_result :: Integer = _
n :: Integer = 19
1  factorial 0 = 1
2  factorial n = n * factorial (n - 1)
                 ^^^^^^^^^^^^^^^^^^^^^
3  
[factorial.hs:2:15-35] *Main>

1つ少ない n があるところまでテップすることができました。

履歴 - :history

GHCi debugger にはスタックトレースを参照する機能は無いのですが、
代わりにバックステップを行なうことができます。
:back コマンドを使うことで、記録されている履歴へ戻ることができます。
記録されている履歴の一覧を :history コマンドで確認することができます。
履歴の中で再び進むには :forward コマンドを使います。

[factorial.hs:2:15-35] *Main> :history
-1  : factorial (factorial.hs:2:30-34)
-2  : factorial (factorial.hs:(1,1)-(2,35))
-3  : factorial (factorial.hs:2:19-35)
-4  : factorial (factorial.hs:2:15-35)
-5  : factorial (factorial.hs:(1,1)-(2,35))
<end of history>
[factorial.hs:2:15-35] *Main> :back
Logged breakpoint at factorial.hs:2:30-34
_result :: Integer
n :: Integer
1  factorial 0 = 1
2  factorial n = n * factorial (n - 1)
                                ^^^^^
3  
[-1: factorial.hs:2:30-34] *Main> :p n
n = 20
[-1: factorial.hs:2:30-34] *Main> :forward
Stopped at factorial.hs:2:15-35
_result :: Integer
n :: Integer
1  factorial 0 = 1
2  factorial n = n * factorial (n - 1)
                 ^^^^^^^^^^^^^^^^^^^^^
3  
[factorial.hs:2:15-35] *Main> :p n
n = 19
[factorial.hs:2:15-35] *Main>

:back コマンドの直後でプロンプトに :history の左端の番号が出ています。
n が 20 であるような状態を再び確認することができました。

追跡 - :trace

ブレークポイントやステップ実行による停止以外で履歴を記録するのに
:trace コマンドを使うことができます。
ここでは factorial の終了条件のときまで止まらないように
ブレークポイントを設定しなおして :trace してみましょう。
:delete コマンドで番号を指定してブレークポイントを削除し、
終了条件の行にブレークポイントを設定してから :trace します。

[factorial.hs:2:15-35] *Main> :show breaks
[0] Main factorial.hs:(1,1)-(2,35)
[factorial.hs:2:15-35] *Main> :delete 0
[factorial.hs:2:15-35] *Main> :show breaks
No active breakpoints.
[factorial.hs:2:15-35] *Main> :b 1
Breakpoint 1 activated at factorial.hs:1:15
[factorial.hs:2:15-35] *Main> :show breaks
[1] Main factorial.hs:1:15
[factorial.hs:2:15-35] *Main> :trace
Stopped at factorial.hs:1:15
_result :: a = _
1  factorial 0 = 1
                 ^
2  factorial n = n * factorial (n - 1)
[factorial.hs:1:15] *Main> :hist
-1  : factorial (factorial.hs:2:30-34)
-2  : factorial (factorial.hs:(1,1)-(2,35))
-3  : factorial (factorial.hs:2:19-35)
-4  : factorial (factorial.hs:2:15-35)
-5  : factorial (factorial.hs:2:30-34)
-6  : factorial (factorial.hs:(1,1)-(2,35))
-7  : factorial (factorial.hs:2:19-35)
-8  : factorial (factorial.hs:2:15-35)
-9  : factorial (factorial.hs:2:30-34)
-10 : factorial (factorial.hs:(1,1)-(2,35))
-11 : factorial (factorial.hs:2:19-35)
-12 : factorial (factorial.hs:2:15-35)
-13 : factorial (factorial.hs:2:30-34)
-14 : factorial (factorial.hs:(1,1)-(2,35))
-15 : factorial (factorial.hs:2:19-35)
-16 : factorial (factorial.hs:2:15-35)
-17 : factorial (factorial.hs:2:30-34)
-18 : factorial (factorial.hs:(1,1)-(2,35))
-19 : factorial (factorial.hs:2:19-35)
-20 : factorial (factorial.hs:2:15-35)
...
[factorial.hs:1:15] *Main> :back
Logged breakpoint at factorial.hs:2:30-34
_result :: Integer
n :: Integer
1  factorial 0 = 1
2  factorial n = n * factorial (n - 1)
                                ^^^^^
3  
[-1: factorial.hs:2:30-34] *Main> :p n
n = 1
[-1: factorial.hs:2:30-34] *Main>

履歴を記録しつつ終了条件まで到達することができました。
一つ前の履歴では n が 1 となっています。

評価が遅延している値

最後に評価が遅延している値を GHCi debugger がどのように扱っているか見てみましょう。

以下のようなクイックソートのプログラムを例にとります。

qsort.hs

qsort [] = [] 
qsort (a:as) = qsort left ++ [a] ++ qsort right
  where (left,right) = (filter (<=a) as, filter (>a) as)

main = print (qsort [8, 4, 0, 3, 1, 23, 11, 18])

プログラムを読み込んで、
qsort関数にブレークポイントを設定し、
関数の中にステップします。
left を :print しても中身が表示されていません。
これは left の値の計算が遅延していてまだ計算されていないからです。

% ghci qsort.hs 
GHCi, version 7.0.4: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
[1 of 1] Compiling Main             ( qsort.hs, interpreted )
Ok, modules loaded: Main.
*Main> :break qsort
Breakpoint 0 activated at qsort.hs:(1,1)-(3,56)
*Main> :set stop :list
*Main> main
Stopped at qsort.hs:(1,1)-(3,56)
_result :: [a] = _
   vv
1  qsort [] = [] 
2  qsort (a:as) = qsort left ++ [a] ++ qsort right
3    where (left,right) = (filter (<=a) as, filter (>a) as)
                                                           ^^
4  
[qsort.hs:(1,1)-(3,56)] *Main> :step
Stopped at qsort.hs:2:16-47
_result :: [a] = _
a :: a = _
left :: [a] = _
right :: [a] = _
1  qsort [] = [] 
2  qsort (a:as) = qsort left ++ [a] ++ qsort right
                  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
3    where (left,right) = (filter (<=a) as, filter (>a) as)
[qsort.hs:2:16-47] *Main> :p left
left = (_t1::[a])
[qsort.hs:2:16-47] *Main>

例えば seq 関数を使って、leftの先頭の構造だけ評価を強制すると、
以下のように表示することができます。

[qsort.hs:2:16-47] *Main> left `seq` ()
()
[qsort.hs:2:16-47] *Main> :p left
left = 4 : (_t2::[Integer])
[qsort.hs:2:16-47] *Main>

構造を辿って評価を強制したいときには :force コマンドを使います。

[qsort.hs:2:16-47] *Main> :force left
left = [4,0,3,1]
[qsort.hs:2:16-47] *Main>

いずれの方法も、評価順序が変化することによって停止しなくなるケースでは注意が必要です。

まとめ

  • GHCi debugger を使うと
    • ブレークポイントによる停止、ステップ実行ができる。
    • 記録された履歴をバックステップで戻って参照できる。
    • 追跡機能で履歴を実行に沿ってまとめて記録できる。
    • 遅延した値を表示するときに評価を強制する必要がある場合、停止するかどうかを注意して使いましょう。

HaskellのLanguage.Java.*を試してみた

Haskell Advent Calendar のためのエントリです。

Haskellのライブラリでlanguage-javaというものを見つけたのでご紹介です。


仕事のプログラムでJavaのコード生成を行なっているものがあり、現状ではテンプレートを穴埋めするような処理をPerlで行なっています。
しかしいろいろと要求が複雑になってくると、穴埋め処理のままではJavaソースコード内の意味の整合を維持するのが次第に面倒になり、ソースコードの構造を意識した処理に置き換えたくなってきました。


Haskellにはそのようなコード生成向けライブラリが無いだろうかと探してみたのがきっかけでした。


http://hackage.haskell.org/package/language-java/


現状だと4つのモジュールを含んでいます。
それぞれ、javaのレキサ (Language.Java.Lexer)、パーサ (Language.Java.Parser)、プリティプリント(Language.Java.Pretty)、構文定義(Language.Java.Syntax)となっているようです。わざわざ説明しなくても良いぐらいに名前のままですね。

Parser

今回はコード生成を行ないたいので、Syntax で定義した構文木を Pretty でフォーマットしてみたいと思います。
しかし、Syntaxの定義を覗いてみるとわかるのですが、構文木を手書きだけでがんばるのはかなり面倒そうです。
なので Parser の機能も使って、構文木を出力させてみることにしました。

Foo.java

package foo.bar;
public class Foo {
    private void foo(String a) {
        System.out.println("Hello " + a);
    }
}

Parse.hs

module Parse where

import Text.ParserCombinators.Parsec (ParseError)
import Language.Java.Syntax (CompilationUnit)
import Language.Java.Parser (parser, compilationUnit)

parseCompilationUnit :: String -> Either ParseError CompilationUnit
parseCompilationUnit =  parser compilationUnit

parse :: FilePath -> IO (Either ParseError CompilationUnit)
parse fn = fmap parseCompilationUnit (readFile fn)
% ghci -hide-package parsec-3.1.0 Parse.hs
GHCi, version 6.12.1: http://www.haskell.org/ghc/  :? for help
Loading .. 略
Ok, modules loaded: Parse.
Prelude Parse> parse "Foo.java"
Loading .. 略
Right
(CompilationUnit (Just (PackageDecl (Name [Ident "foo",Ident "bar"])))
 [] [ClassTypeDecl (ClassDecl [Public] (Ident "Foo") [] Nothing []
 (ClassBody [MemberDecl (MethodDecl [Private] [] Nothing (Ident "foo")
 [FormalParam [] (RefType (ClassRefType (ClassType [(Ident
 "String",[])]))) False (VarId (Ident "a"))] [] (MethodBody (Just
 (Block [BlockStmt (ExpStmt (MethodInv (MethodCall (Name [Ident
 "System",Ident "out",Ident "println"]) [BinOp (Lit (String "Hello "))
 Add (ExpName (Name [Ident "a"]))])))]))))]))])
Prelude Parse> 

それらしく動作しているようです。
しかし、ちょっと注意が必要だったのは language-java は parsec の version 2 に依存しているらしく、parsec の version 3 と parsec の version 2 をインストールしている環境では競合が起きてしまいます。
ghc に -hide-package parsec-3.1.0 というように parsec の version 3 を hide するようにしてやると、競合を解決することができるようです。

Pretty

次は Pretty Printer を試してみました。

FooP.hs

module FooP where

import Text.PrettyPrint.HughesPJ (render)
import Language.Java.Pretty (pretty, Pretty)
import Language.Java.Syntax

showCompilationUnit :: Pretty a => a -> IO ()
showCompilationUnit =  putStrLn . render . pretty

ast0 :: CompilationUnit
ast0 =
 CompilationUnit (Just (PackageDecl (Name [Ident "foo",Ident "bar"])))
 [] [ClassTypeDecl (ClassDecl [Public] (Ident "Foo") [] Nothing []
 (ClassBody [MemberDecl (MethodDecl [Private] [] Nothing (Ident "foo")
 [FormalParam [] (RefType (ClassRefType (ClassType [(Ident
 "String",[])]))) False (VarId (Ident "a"))] [] (MethodBody (Just
 (Block [BlockStmt (ExpStmt (MethodInv (MethodCall (Name [Ident
 "System",Ident "out",Ident "println"]) [BinOp (Lit (String "Hello "))
 Add (ExpName (Name [Ident "a"]))])))]))))]))]

test0 :: IO()
test0 =  showCompilationUnit ast0
.. 略
Prelude FooP> test0
Loading .. 略
package foo.bar;
public class Foo
{
  private void foo (String a)
  {
    System.out.println("Hello " + a);
  }
}
Prelude FooP>

無事にもとに戻ってきたようです。

バグとか

上の例では問題はなさそうですが、いろいろ試してみた結果、問題も見つかりました。

Bad0.java

package foo.bar;
public class Bad0 {
    private synchronized void foo() {}
}
.. 略
Prelude Parse> parse "Bad0.java"
Loading .. 略
Left (line 3, column 13):
unexpected KW_Synchronized
expecting refType or resultType
Prelude Parse> 

synchronized のところでエラーになってしまいました。

--- bug/haskell-language-java-0.1.0/Language/Java/Parser.hs
+++ haskell-language-java-0.1.0/Language/Java/Parser.hs
@@ -294,6 +294,7 @@
     <|> tok KW_Native      >> return Native    
     <|> tok KW_Transient   >> return Transient 
     <|> tok KW_Volatile    >> return Volatile  
+    <|> tok KW_Synchronized >> return ModSynchronized
 
 ----------------------------------------------------------------------------
 -- Variable declarations
--- bug/haskell-language-java-0.1.0/Language/Java/Syntax.hs
+++ haskell-language-java-0.1.0/Language/Java/Syntax.hs
@@ -149,6 +149,7 @@
     | Transient
     | Volatile
     | Native
+    | ModSynchronized
   deriving (Eq, Show)
 
 -----------------------------------------------------------------------

調べてみたところ、modifier に synchronized を書き忘れている単純なミスのようでした。
加えてみるとあっさり直りました。


もうひとつ、parsecのバックトラックの罠にハマっていそうな問題もありました。

Bad1.java

/**/
package foo.bar;
public class Bad1 {
    private void foo() {}
}
/**/

このように上下をコメントではさんだコードにすると、

.. 略
Prelude Parse> parse "Bad1.java"
Loading .. 略
Right (CompilationUnit Nothing [] [])
Prelude Parse> 

なんと、parseの結果が空になってしまいました。こちら問題はまだ原因を調査中です。なにか分かったらまた書くかもしれません。

まとめ

  • language-javaを使うとHaskellからJava構文木を操作できそう。
  • でもまだバグがある。まだ新しいライブラリのようなので、今後に期待。