抽象構文木の書き方のアイデア

はじめに

抽象構文木の書き方を色々と試行錯誤していて考えついた方法について書いておこうと思います。

Haskell で抽象構文木を書く方法はかなり色々あります。

例えば

data で定義する
GADTs を使った方法
Fix を使った方法 (Data types à la carte)
Tagless Final を使った方法

などなど。

なかなか決めるのが難しいですが、コンパイラや EDSL など色々と応用できそうなところなので色々調べたりしていました。

アイデア

下のような機能が欲しいと考えていました。

拡張できるようにしたい
戻り値などの型を付けたい
制約を付けられるようにしたい

拡張できるようにしたい

拡張して色々な構文を足していけるようになっていると、ボトムアップな感じで書けるので書きやすいかなと思います。あとライブラリを使う側で後から構文を足したりしたい場合があると思います。

このために Data types à la carte に似た書き方を使うことにしました。

data Expr f = In (f (Expr f))
data (f :+: g) e = Inl (f e) | Inr (g e)
data Add e = Add e e
data Val e = Val Int

addExample :: Expr (Val :+: Add)
addExample = In (Inr (Add (In (Inl (Val 118))) (In (Inl (Val 1219)))))

詳しくは

http://www.cs.ru.nl/~W.Swierstra/Publications/DataTypesALaCarte.pdf

この書き方では各構文を Functor として定義して :+: (Coproduct) で合成し、不動点演算のような型で再帰的な構造を表現しています。

色々書き方を変えていますが私の方法でも同じように再帰的な型を定義して使っています。

戻り値などの型を付けたい

構文木に型が付いていると EDSL で間違った書き方を制限したりできます。

これは GADTs の拡張を使うと簡単にできます。

data Add g a where
    Add :: (Num a) => g a -> g a -> Add g a

data Equ g a where
    Equ :: (Eq a) => g a -> g a -> Equ g Bool

しかし型の制限を入れることでやりにくくなることもあって Functor のインスタンスにはできなくなります。

Data types à la carte では各構文の data を Functor のインスタンスにしていたので同じやり方はできなくなってしまいます。

このため extensible ライブラリの Sum を使うことにしました。

Data.Extensible.Sum

extensible の Sum は色々な種の型を組み合わせることができるようです。

match という関数あたりを使うと構文木を文字列として出力したり、インタープリタを作ったりもできそうです。

構文木のコードは下のようになります。 xs の型パラメーターに構文の data の型リストが入る感じになります。

data Node g a (f :: (* -> *) -> * -> *) where
    Node :: f g a -> Node g a f

newtype Expr xs a = Expr { unExpr :: Node (Expr xs) a :| xs }

制約を付けられるようにしたい

引数の型や戻り値の型の他にも制約が欲しい場合があると思います。

例えば変数のスコープなどがあります。

制約を表現するために各構文木のノードを monad に入れることにしました。

また monad を外して親ノードと型を合わせることも必要になります。

このために mmorph の MFunctor と同じような型クラスを使っています。

class Hoist (t :: (* -> *) -> * -> *) where
    hoist :: (forall x. f x -> g x) -> t f a -> t g a

data Node m g a (f :: (* -> *) -> * -> *) where
    Node :: (Hoist f) => m (f g a) -> Node m g a f

newtype Expr xs m a = Expr { unExpr :: Node m (Expr xs m) a :| xs }

hoistExpr :: (Functor n) => (forall x. m x -> n x) -> Expr xs m a -> Expr xs n a
hoistExpr f (Expr (EmbedAt p (Node m))) = Expr (EmbedAt p (Node (hoist (hoistExpr f) <$> f m)))

ただ変数を EDSL に使う方法としては HOAS (Higher-order abstract syntax) という方法があって、そちらを使うほうが簡単かもしれません。

Higher-order abstract syntax - Wikipedia

コードの全体

実験コードは下のような感じになりました。

{-# LANGUAGE OverloadedStrings, DataKinds, FlexibleContexts, GADTs, KindSignatures, RankNTypes, TypeFamilies, TypeOperators #-}
module Main where

import Data.Extensible (Member, Match(..), (:|)(..), (:*), (<:), embed, hindex, nil)
import Data.Functor.Identity (Identity(..))

class Ast g where
    type NodeTypes g :: [(* -> *) -> * -> *]
    mkAst :: (Monad m, Hoist v, Member (NodeTypes g) v) => m (v (g m) a) -> g m a

class Hoist (t :: (* -> *) -> * -> *) where
    hoist :: (forall x. f x -> g x) -> t f a -> t g a

data Node m g a (f :: (* -> *) -> * -> *) where
    Node :: (Hoist f) => m (f g a) -> Node m g a f

newtype Expr xs m a = Expr { unExpr :: Node m (Expr xs m) a :| xs }

instance Ast (Expr xs) where
    type NodeTypes (Expr xs) = xs
    mkAst = Expr . embed . Node

hoistExpr :: (Functor n) => (forall x. m x -> n x) -> Expr xs m a -> Expr xs n a
hoistExpr f (Expr (EmbedAt p (Node m))) = Expr (EmbedAt p (Node (hoist (hoistExpr f) <$> f m)))

data Add g a where
    Add :: (Num a) => g a -> g a -> Add g a

instance Hoist Add where
    hoist f (Add a0 a1) = Add (f a0) (f a1)

add :: (Ast g, Monad m, Member (NodeTypes g) Add, Num a) => g m a -> g m a -> g m a
add a0 a1 = mkAst . return $ Add a0 a1

data Mul g a where
    Mul :: (Num a) => g a -> g a -> Mul g a

instance Hoist Mul where
    hoist f (Mul a0 a1) = Mul (f a0) (f a1)

mul :: (Ast g, Monad m, Member (NodeTypes g) Mul, Num a) => g m a -> g m a -> g m a
mul a0 a1 = mkAst . return $ Mul a0 a1

data Equ g a where
    Equ :: (Eq a) => g a -> g a -> Equ g Bool

instance Hoist Equ where
    hoist f (Equ a0 a1) = Equ (f a0) (f a1)

equ :: (Ast g, Monad m, Member (NodeTypes g) Equ, Eq a) => g m a -> g m a -> g m Bool
equ a0 a1 = mkAst . return $ Equ a0 a1

data Lit (g :: * -> *) a where
    LitInt :: Int -> Lit g Int
    LitBool :: Bool -> Lit g Bool

instance Hoist Lit where
    hoist _ (LitInt a) = LitInt a
    hoist _ (LitBool a) = LitBool a

int :: (Ast g, Monad m, Member (NodeTypes g) Lit) => Int -> g m Int
int = mkAst . return . LitInt

bool :: (Ast g, Monad m, Member (NodeTypes g) Lit) => Bool -> g m Bool
bool = mkAst . return . LitBool

newtype Printer (g :: * -> *) (v :: (* -> *) -> * -> *) = Printer
    { runPrinter :: forall a. v g a -> String }

printExpr :: Printer (Expr xs Identity) :* xs -> Expr xs Identity a -> String
printExpr printers (Expr (EmbedAt membership (Node (Identity a)))) = runPrinter (hindex printers membership) a

printAdd :: (forall a. g a -> String) -> Add g a -> String
printAdd p (Add a0 a1) = "(" ++ p a0 ++ " + " ++ p a1 ++ ")"

printMul :: (forall a. g a -> String) -> Mul g a -> String
printMul p (Mul a0 a1) = "(" ++ p a0 ++ " * " ++ p a1 ++ ")"

printEqu :: (forall a. g a -> String) -> Equ g a -> String
printEqu p (Equ a0 a1) = "(" ++ p a0 ++ " == " ++ p a1 ++ ")"

printLit :: (forall a. g a -> String) -> Lit g a -> String
printLit _ (LitInt a) = show a
printLit _ (LitBool a) = show a

type Nodes = '[Add, Mul, Equ, Lit]
type E = Expr Nodes Identity
type Printers xs a = Printer (Expr xs Identity) :* xs

printers :: (forall a. Expr Nodes Identity a -> String) -> Printers Nodes a
printers p
    =  Printer (printAdd p)
    <: Printer (printMul p)
    <: Printer (printEqu p)
    <: Printer (printLit p)
    <: nil

pp :: Expr Nodes Identity a -> String
pp = printExpr (printers pp)

e1 :: (Member xs Add, Member xs Mul, Member xs Equ, Member xs Lit, Monad m) => Expr xs m Bool
e1 = equ (add (mul (int 1) (int 2)) (add (int 3) (int 4))) (mul (int 5) (int 2))

main :: IO ()
main = do
    putStrLn . pp $ e1

まとめ

抽象構文木の実装のアイデアについて書いてみました。

この書き方で SQL のクエリを生成するライブラリを書いてみようと思って下のリポジトリで実装してみています。

https://github.com/bigsleep/extensible-sql

まだ完成には遠いですがある程度動くようになったら記事にまとめたりしたいです。