LoginSignup
9
2

More than 1 year has passed since last update.

@autotaker1984in株式会社Works Human Intelligence

Yet another extensible records for Haskell

Last updated at Posted at 2021-05-15

はじめに

Haskellにおける拡張可能レコードは extensible が有名ですが、
今回新たな拡張可能レコードライブラリを作ったので紹介します。

Row polymorphism

Row polymorphismとは特定のフィールドを持ったレコード型ならなんでも渡せるような関数を書く方法です。
例えばPureScriptでは以下のようなInt型のフィールドfooを持つ任意のレコードを渡せる関数fを定義することができます。

f :: forall r. { foo :: Int | r } -> Int
f x = x.foo + 1

>>> f { foo : 10, bar : True } 
11
>>> f { foo : 3 } 
4

Haskellでもextensibleを使うとRow polymorphismを再現できます。

import Data.Extensible
import Control.Lens

f :: Lookup xs "foo" Int => Record xs -> Int
f = x ^. #foo + 1

>>> f ( #foo @= 11 <: #bar @= True <: nil )
11
>>> f ( #foo @= 3 <: nil )
4

レコードの拡張と部分適用

さて、あるレコードに対して、特定のフィールドを追加したい場合はどのようにしたら良いでしょうか？
extensibleでは(<:)演算子を使ってレコードを拡張できます。

extendBar :: Record xs -> Record ("bar" :> Bool ': xs)
extendBar x = #bar @= True <: x

この演算子をつかってフィールドの部分適用はできるでしょうか？
ここでいう部分適用とは必要なフィールドのうち一部分だけを渡すことです。
例えば、fooフィールドとbarフィールドが必要なレコードを引数にとる関数fのうち、
barフィールドだけ部分適用したapplyBarFを定義することです。

f :: (Lookup xs "foo" Int, Lookup xs "bar" Bool) => Record xs -> Int
f = ...

applyBarF :: Lookup xs "foo" Int => Record xs -> Int
applyBarF = ???

直感的には以下のように書けそうです。

applyBarF :: Lookup xs "foo" Int => Record xs -> Int
applyBarF x = f (#bar @= True <: x)

しかし残念ながら型エラーが発生します。（もしこの型エラーの直し方をご存知の方がいたら教えていただけると嬉しいです）

Extensible.hs:18:15: error:
    • Couldn't match type ‘Type.Membership.Internal.Elaborate
                             "bar"
                             ((0 ':> Bool) : Type.Membership.Internal.FindAssoc 1 "bar" xs)’
                     with ‘'Type.Membership.Internal.Expecting (n0 ':> Bool)’
        arising from a use of ‘f’
      The type variable ‘n0’ is ambiguous
    • In the expression: f (#bar @= True <: x)
      In an equation for ‘applyBarF’: applyBarF x = f (#bar @= True <: x)
    • Relevant bindings include
        x :: Record xs (bound at tmp/Extensible.hs:18:11)
        applyBarF :: Record xs -> Int (bound at tmp/Extensible.hs:18:1)
   |
18 | applyBarF x = f (#bar @= True <: x)

以下のようにfooフィールドを取り出してきて別のレコードを作れば動きますが、いちいち
フィールドを取り出すのは面倒でしょう。

applyBarF :: Lookup xs "foo" Int => Record xs -> Int
applyBarF x = f (#bar @= True <: #foo @= (x ^. #foo) <: nil)

ちなみにPureScriptなら部分適用ができます。

import Prim.Row
import Record
import Type.Proxy

f :: forall r. { foo:: Int, bar :: Boolean | r} -> Int
f x = ...

applyBarF :: forall r. Lacks "bar" r => { foo :: Int | r } -> Int
applyBarF x = f (insert (Proxy :: Proxy "bar") true x)

レコード拡張のコスト

さて、フィールド数$n$のレコードを$d$個のフィールドで拡張するときに発生する計算コストはどれだけでしょうか？

  • extensibleではレコードは配列として実装されています。配列の拡張を行うので$\mathcal{O}(n+d)$の時間がかかります。
  • PureScriptではレコードはJavaScriptのレコード（おそらくハッシュテーブル）で表現されます。拡張時にはレコードのコピーを行うので$\mathcal{O}(n+d)$の時間がかかります。

フィールド数が多くレコードの拡張が頻繁に発生する場合、このコストは無視できません。

Nominal Subtyping

さて、今回は以下のようなレコード型ライブラリを紹介します。

  • Row polymorphismを実現
  • レコードの部分適用に正しく型が付けられる
  • フィールド数$n$のレコードに$d$個のフィールドを追加するコストが$\mathcal{O}(d)$

これを実現する基本的なアイデアはNominal Subtypingです。

extensibleやPureScriptのレコードはstructural subtypingであり、
レコードを拡張すると全く別の型になります。

Untitled Diagram.png

一方、Nominal Subtypingではレコード同士の親子関係を定義し、親レコードをポインタで持つようにします。
Untitled Diagram-Page-2.png

こうすることで、レコードの拡張を$\mathcal{O}(d)$のコストで実現できます。1
あとは型レベルプログラミングで頑張ると先祖レコードのフィールドにも自在にアクセスできるようになり、
Row polymorphismやレコード部分適用を実現できます。

Nominal Extensible Records

使い方

今回紹介するレコード型の実装はhierarchical-envというライブラリにまとめています。

まず、以下の言語拡張を有効にしてモジュールをインポートしましょう。

Env.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Env where

import Control.Env.Hierarchical
import Control.Lens

レコードの宣言

hierarchical-envでは各レコードを普通のデータ型として宣言します。
手始めにInt型とString型をフィールドに持つEnv1型を定義して、deriveEnv ''Env1と呪文を唱えます。

Env.hs
data Env1 = Env1 Int String deriving (Show)

deriveEnv ''Env1

env1 = Env1 1 "hoge"

各フィールドにはgetLレンズをつかってアクセスします。

$ ghci Env.hs 
> import Control.Lens
> import Control.Env.Hierarchical
> env1 ^. getL :: Int
1
> env1 ^. getL :: String
"hoge"
> env1 & getL .~ "fuga"
Env1 1 "fuga"

フィールド名

レコードと言いつつフィールド名は本質的でないので今のところサポートしていません。
名前をつけたい（同じ型のフィールドを複数持ちたい）場合はnewtypeでフィールドの型に名前をつけるスタイルを推奨しています。

Env.hs
data Env2 = Env2 Port APIKey HostName deriving (Show)

newtype Port = Port Int deriving (Show)

newtype APIKey = APIKey String deriving (Show)

newtype HostName = HostName String deriving (Show)

deriveEnv ''Env2

> env2 ^. getL :: Port
Port 1234
> env2 & getL .~ APIKey "PRODUCTION_KEY"
Env2 (Port 1234) (APIKey "PRODUCTION_KEY") (HostName "localhost")

レコード拡張

さて、お待ちかねのレコードの拡張です。親レコードをExtends型で包んだフィールドを追加することでレコードの親子関係を宣言します。

Env.hs
data Env3 = Env3 LogFilePath (Extends Env2) deriving (Show)

newtype LogFilePath = LogFilePath String deriving (Show)

deriveEnv ''Env3

env3 = Env3 (LogFilePath "system.log") (Extends env2)

拡張したレコードでは親レコードのフィールドにもgetLでアクセスできます。

> env3 ^. getL :: Port
Port 1234
> env3 ^. getL :: LogFilePath 
LogFilePath "system.log"

Row Polymorphism

Has x env型制約をつかってRow Polymorphismを表現できます。

Env.hs
f :: (Has LogFilePath env, Has HostName env) => env -> IO ()
f env = do
  print $ (env ^. getL :: LogFilePath)
  print $ (env ^. getL :: HostName)

以下のようにenv3は引数に渡せますが、env2はLogFilePathを持たないのでエラーとなります。

> f env3
LogFilePath "system.log"
HostName "localhost"
> f env2

<interactive>:23:1: error:
    • No environment has LogFilePath
    • In the expression: f env2
      In an equation for ‘it’: it = f env2

レコードの部分適用

親レコードに型変数を指定することでレコードの部分適用ができます。

Env.hs
data Env4 env = Env4 LogFilePath (Extends env) deriving(Show)

deriveEnv ''Env4

g :: Has HostName env => env -> IO ()
g env = f (Env4 (LogFilePath "error.log") $ Extends env)

> g env2
LogFilePath "error.log"
HostName "localhost"

作り方

ここから先はライブラリの実装についての説明です。
型レベルプログラミングをバリバリ使っています。ご了承ください。

方法1: Hasを型クラスとして実装する

一番素朴な実装方法はHas x envを以下のような型クラスにすることでしょう。

class Has x env where
  getL :: Lens' env x

この場合は各レコードとそのフィールド毎にインスタンスを定義します。
例えば以下のようなレコードでは

data Env1 = Env1 Int Bool

data Env2 = Env2 Char (Extends Env1)

次のインスタンスを宣言すれば良いです。

instance Has Int Env1 where
  getL f (Env1 x1 x2) = fmap (\y1 -> Env1 y1 x2) (f x1)

instance Has Bool Env1 where
  getL f (Env1 x1 x2) = fmap (\y2 -> Env1 x1 y2) (f x2)

instance Has Char Env2 where
  getL f (Env2 x1 x2) = fmap (\y1 -> Env2 y1 x2) (f x1)

instance {-# OVERLAPS #-} Has x Env1 => Has x Env2 where
  getL = superL . getL
    where
      superL f (Env2 x1 (Extends x2)) = fmap (\y2 -> Env2 x1 (Extends y2)) (f x2)

この方法はシンプルで良いのですが、フィールドの型が具体的に分かっている必要があります。
普通のデータ型ならフィールドの型は分かっているので問題ないのですが、拡張可能レコード等のインスタンスを宣言できません。

instance ??? => Has x (Record xs) where
  getL = ???

うまく宣言できない理由は、xが自身のフィールドなのか親レコードのフィールドなのかをRecord xsの形のみから判断できないためです。

方法2: 型レベル計算による実装

こちらの方法が実際にhierarchical-envで採用されている方法になります。

Has x envを二つの型クラスTrans env routeとField x env'に分解します。

type Has x env = (Trans env route, Field x env')
  where -- 実際にはwhere記法なんてものはないので展開しています。 
    route = FindEnv x env (Addr env)
    env' = Target env route

Trans env route型クラスは型レベルリストrouteに従って親レコードを辿ると、Target env route型に遷移できることを表します。
一方Field x env'型クラスはenv'型の（直接の）フィールドにxがあることを表します。

class Trans env route where
  type Target env route
  transL :: Lens' env (Target env route)

instance Trans s '[] where
  type Target s '[] = s
  transL = id

instance (Environment s, Super s ~ t, Trans t l) => Trans s (t : l) where
  type Target s (t : l) = Target t l
  transL = superL . transL @t @l

class Field x env where
  fieldL :: Lens' env x

これらを組み合わせるとgetLを定義できます。

getL :: forall x env. Has x env => Lens' env x
getL = transL @env @(FindEnv x env (Addr env)) . fieldL

下図のようにtransLで型xをフィールドにもつレコードまで遷移し、fieldLで型xにアクセスするというイメージです。

Untitled Diagram-Page-3.png

問題は型xをフィールドに持つレコードを見つけることです。これを型レベル計算で求めるところがポイントです。

型族FindEnv x env envsとAddr envがその責務を担っています。
探索する際には「各レコードのフィールドのリスト」や「各レコードの親クラス」が必要なのですが、これらはEnvironment型クラスで宣言します。

-- | 親レコードのリスト`envs`を辿りながら、`f`をフィールドに持つレコードを探します
type family FindEnv (f :: Type) env (envs :: [Type]) :: [Type] where
  FindEnv f env (env' ': envs) = If (Member f (Fields env)) '[] (env' : FindEnv f env' envs)
  FindEnv f env '[] = TypeError ('Text "No environment has " ':<>: 'ShowType f)

-- | レコード`env`の先祖レコードのリストを返します。
type family Addr a :: [Type] where
  Addr Root = '[]
  Addr a = Super a ': Addr (Super a)

-- | 各レコードが実装する型クラス
class Environment env where
  -- | 親レコード
  type Super env
  -- | フィールドの型のリスト
  type Fields env :: [Type]
  -- | 親レコードへのLens
  superL :: Lens' env (Super env)

このやり方ではEnvironment envとField x envのインスタンスがボイラープレートとして定義する必要があります。

例えば

data Env1 = Env1 Int Bool

data Env2 = Env2 Char (Extends Env1)

に対して、以下のようなインスタンスを宣言します。
実際にはTemplateHaskellderiveEnvを使って自動生成します。

instance Environment Env1 where
  type Super Env1 = Root
  type Fields Env1 = '[Int, Bool]
  superL f e = fmap (const e) (f Root)

instance Field Int Env1 where
  fieldL f (Env1 x1 x2) = fmap (\y1 -> Env1 y1 x2) (f x1)

instance Field Bool Env1 where
  fieldL f (Env1 x1 x2) = fmap (\y2 -> Env1 x1 y2) (f x2)

instance Environment Env2 where
  type Super Env2 = Env1 
  type Fields Env2 = '[Char]
  superL f (Env2 x1 (Extends x2)) = fmap (\y2 -> Env2 x1 (Extends y2)) (f x2)

instance Field Char Env2 where
  fieldL f (Env2 x1 x2) = fmap (\y1 -> Env2 y1 x2) (f x1)

まとめ

今回紹介したhierarchical-envは以下のような特徴を持っています。

  • Row polymorphismを実現
  • レコードの部分適用に正しく型が付けられる
  • フィールド数$n$のレコードに$d$個のフィールドを追加するコストが$\mathcal{O}(d)$

このライブラリはレコードの拡張が部分適用が頻繁におこるユースケース（特にDependency Injection)で力を発揮します。 具体的な応用例は以下のチュートリアルをご覧ください。

是非使ってみていただけるとうれしいです。

  1. もちろんこのやり方にするとフィールドを取得する際にレコードの親子関係を線形走査する必要があり、ネストの深いところにあるフィールドを取得するのにコストがかかるという欠点はあります。 ↩

9
2
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
9
2