TypeFamilyDependenciesの実用的な例を考える

FunctionalDependenciesというGHC言語拡張がある．Haskell Wikiによると，

Functional dependencies are used to constrain the parameters of type classes.

と書かれているが，これはどういうことか．

Haskell Language Reportで定められた範囲では，型クラスに与えられるパラメータは1つに限られるが，MultiParamTypeClassesを用いると，複数のパラメータを与えることができる．この際に，パラメータとして与えられた（複数の）型の間の関係性に制限を加えることができるのが，FunctionalDependenciesなのであった．恐らく多くの人が初めて目にするのは，mtl packageのMonadReaderの定義なのではないだろうか．| m -> rというのがそれである．

class Monad m => MonadReader r m | m -> r where
   ...

さて，GHC 8からTypeFamilyDependenciesというGHC言語拡張が追加された．これについては既にlotz先生が『型族が単射だと嬉しい理由』という記事を書いていらっしゃるのだが，（氏には失礼ながら）少しばかりわざとらしい例だと感じたので，もう少し実務的な例を引き合いに出して，有用性を示したいと思う．

この記事では，以下のGHC言語拡張を使う．また，GHCのヴァージョンは8.2.2である．

AllowAmbiguousTypes
OverloadedStrings
ScopedTypeVariables
TypeApplications
TypeFamilies
TypeFamilyDependencies

以下のようなUser型とUserKey型を関係データベースで扱いたいとしよう．UserKey型は（典型的にはauto incrementな）primary keyだと思ってもらえば良い．

data User
    = User
    { userName :: String
    , userAge  :: Int
    }

newtype UserKey = UserKey { unUserKey :: Int } deriving (Eq, Show)

さてここで，DBの中ではprimary keyとしてINT型を用いたいが，エンドユーザからはその整数の表現を隠蔽したいものとしよう．そのためには，整数をいい感じにエンコード・デコードしたものを，primary keyの表現として用いればよさそうだ．このようなモチベーションはよくあるので，Hashids^*1というライブラリが公開されている．これは様々な言語向けに実装が提供されていて，Haskell版もHackageから入手可能である．

このライブラリが（DB上での内部表現である）Intと（エンドユーザが目にする表現である）ByteStringの間の相互変換を提供してくれる．エンコードされたUserKeyを表現する次のような型を定義しよう．

newtype EncodedUserKey = EncodedUserKey { unEncodedUserKey :: ByteString } deriving (Eq, Show)

次に，UserKeyとEncodedUserKeyを相互に変換するencodeUserKey関数とdecodeUserKey関数を定義する．

encodeUserKey :: UserKey -> EncodedUserKey
encodeUserKey (UserKey n) = EncodedUserKey $ encodeUsingSalt "this is my salt" n

decodeUserKey :: EncodedUserKey -> Maybe UserKey
decodeUserKey (EncodedUserKey x) =
    case decodeUsingSalt "this is my salt" x of
        [n] -> Just (UserKey n)
        _   -> Nothing

GHCiで挙動を確認してみよう．

> encodeUserKey $ UserKey 42
EncodedUserKey {unEncodedUserKey = "eP"}

> decodeUserKey $ encodeUserKey $ UserKey 42
Just (UserKey {unUserKey = 42})

さてここでUserに加えて，新たにTeamという概念が増えたとしよう．Teamのprimary keyもUserと同様に，hashidsを使って隠蔽したいとする．

data Team
    = Team
    { teamName  :: String
    , teamUsers :: [User]
    } deriving (Show)

newtype TeamKey = TeamKey { unTeamKey :: Int } deriving (Eq, Show)

newtype EncodedTeamKey = EncodedTeamKey { unEncodedTeamKey :: ByteString } deriving (Eq, Show)

encodeTeamKey :: TeamKey -> EncodedTeamKey
encodeTeamKey (TeamKey n) = EncodedTeamKey $ encodeUsingSalt "another salt" n

decodeTeamKey :: EncodedTeamKey -> Maybe TeamKey
decodeTeamKey (EncodedTeamKey x) =
    case decodeUsingSalt "another salt" x of
        [n] -> Just (TeamKey n)
        _   -> Nothing

Userの場合とまったく同じ実装になってしまったので，これらを型クラスで抽象化しよう．先にUser型やTeam型を取って，そのkeyを返す型レヴェル関数Keyをtype familyを用いて定義する．つまり，

User $\mapsto$ UserKey
Team $\mapsto$ TeamKey

なる型レヴェル関数である．また，ついでなので，Keyの中身のIntを取り出したり，またIntを取ってKeyを作る部分を抽象化しておく．

-- 何かしらのkeyを持つことを表す型クラス
class HasKey a where
    type Key a -- aをとってkeyを返す型レヴェル関数（e.g. Key User = UserKey）
    wrapKey   :: Int -> Key a
    unwrapKey :: Key a -> Int

instance HasKey User where
    type Key User = UserKey
    wrapKey = UserKey
    unwrapKey = unUserKey

instance HasKey Team where
    type Key Team = TeamKey
    wrapKey = TeamKey
    unwrapKey = unTeamKey

今しがた定義したHasKeyを前提に，いよいよHasCodableKey型クラスを定義する．

-- Keyをhashidsでエンコード・デコードできることを表す型クラス
class HasKey a => HasCodableKey a where
    -- エンコードされたkey（e.g. EncodedUserKey）
    type EncodedKey a

    wrapEncodedKey   :: ByteString -> EncodedKey a
    unwrapEncodedKey :: EncodedKey a -> ByteString

    -- saltは変えられるようにしておく
    salt :: ByteString

    encodeKey :: Key a -> EncodedKey a
    encodeKey key =
        let n = unwrapKey key
            bs = encodeUsingSalt (salt @a) n
        in wrapEncodedKey bs

    decodeKey :: EncodedKey a -> Maybe (Key a)
    decodeKey encodedKey =
        let bs = unwrapEncodedKey encodedKey
            ns = decodeUsingSalt (salt @a) bs
        in case ns of
            [n] -> Just (wrapKey n)
            _   -> Nothing

上のように定義すると，メッチャ怒られる．

/Users/ryota-ka/dev/tf-deps-example/src/Lib.hs:64:27: error:
    • Couldn't match expected type ‘Key a0’ with actual type ‘Key a’
      NB: ‘Key’ is a type function, and may not be injective
      The type variable ‘a0’ is ambiguous
    • In the first argument of ‘unwrapKey’, namely ‘key’
      In the expression: unwrapKey key
      In an equation for ‘n’: n = unwrapKey key
    • Relevant bindings include
        key :: Key a (bound at src/Lib.hs:63:15)
        encodeKey :: Key a -> EncodedKey a (bound at src/Lib.hs:63:5)
   |
64 |         let n = unwrapKey key
   |                           ^^^

/Users/ryota-ka/dev/tf-deps-example/src/Lib.hs:66:12: error:
    • Couldn't match expected type ‘EncodedKey a’
                  with actual type ‘EncodedKey a1’
      NB: ‘EncodedKey’ is a type function, and may not be injective
      The type variable ‘a1’ is ambiguous
    • In the expression: wrapEncodedKey bs
      In the expression:
        let
          n = unwrapKey key
          bs = encodeUsingSalt (salt @a) n
        in wrapEncodedKey bs
      In an equation for ‘encodeKey’:
          encodeKey key
            = let
                n = unwrapKey key
                bs = encodeUsingSalt (salt @a) n
              in wrapEncodedKey bs
    • Relevant bindings include
        key :: Key a (bound at src/Lib.hs:63:15)
        encodeKey :: Key a -> EncodedKey a (bound at src/Lib.hs:63:5)
   |
66 |         in wrapEncodedKey bs
   |            ^^^^^^^^^^^^^^^^^

/Users/ryota-ka/dev/tf-deps-example/src/Lib.hs:70:35: error:
    • Couldn't match expected type ‘EncodedKey a2’
                  with actual type ‘EncodedKey a’
      NB: ‘EncodedKey’ is a type function, and may not be injective
      The type variable ‘a2’ is ambiguous
    • In the first argument of ‘unwrapEncodedKey’, namely ‘encodedKey’
      In the expression: unwrapEncodedKey encodedKey
      In an equation for ‘bs’: bs = unwrapEncodedKey encodedKey
    • Relevant bindings include
        encodedKey :: EncodedKey a (bound at src/Lib.hs:69:15)
        decodeKey :: EncodedKey a -> Maybe (Key a)
          (bound at src/Lib.hs:69:5)
   |
70 |         let bs = unwrapEncodedKey encodedKey
   |                                   ^^^^^^^^^^

/Users/ryota-ka/dev/tf-deps-example/src/Lib.hs:74:20: error:
    • Couldn't match type ‘Key a’ with ‘Key a3’
      Expected type: Maybe (Key a)
        Actual type: Maybe (Key a3)
      NB: ‘Key’ is a type function, and may not be injective
      The type variable ‘a3’ is ambiguous
    • In the expression: Nothing
      In a case alternative: _ -> Nothing
      In the expression:
        case ns of
          [n] -> Just (wrapKey n)
          _ -> Nothing
    • Relevant bindings include
        encodedKey :: EncodedKey a (bound at src/Lib.hs:69:15)
        decodeKey :: EncodedKey a -> Maybe (Key a)
          (bound at src/Lib.hs:69:5)
   |
74 |             _   -> Nothing
   |                    ^^^^^^^

よくよく読んでみると，「型レヴェル関数であるKeyとかEncodedKeyが単射（injective）ではないぞ」と言われている．

関数 $f: A \to B$ が単射であるとは， $\forall x, y \in A$ について $x \neq y \Rightarrow f(x) \neq f(y)$ ということであるが，直感的には $f$ で写した先の集合 $B$ で要素が互いにぶつからないとイメージすることができる．今回の場合EncodedKeyは，

User $\mapsto$ EncodedUserKey
Company $\mapsto$ EncodedCompanyKey

といった挙動をするが，User以外の適当な型aを持ってきて，それをEncodedUserKeyに写されると困るのである．

関数で写した先でぶつからないということは，取りも直さず写した先の要素 $f(x) \in B$ から，写す前の要素 $x \in A$ を一意に特定できるということを意味する．つまり，EncodedUserKeyからUser型を特定でき，EncodedTeamKeyからはTeam型を特定することができる．「この型レヴェル関数はこのようにinjectiveに振る舞いますよ，（aからEncodedKey aが定まることは当然として，逆に）EncodedKey aからaが定まることを前提に型推論してくださいね」という注記を与えるための機能こそがTypeFamilyDependenciesだったのだ．

では実際にTypeFamilyDependenciesを有効にして，先程のコードの型検査が通るように書き換えてみよう．

before.hs

class HasKey a where
    type Key a

class HasKey a => HasCodableKey a where
    type EncodedKey a

after.hs

class HasKey a where
    type Key a = r | r -> a

class HasKey a => HasCodableKey a where
    type EncodedKey a = r | r -> a

ここでrなり何なり適当な名前を与えてあげないと，単射性の制約が書けない^*2．r -> aの部分は，型rから型aが一意に定まることを表している．

カインドの制約が書きたければ，次のようにも書くことができる．

class HasKey a where
    type Key a = (r :: *) | r -> a

これで無事にHasCodableKey型クラスが定義できたので，UserとTeamをこいつのインスタンスにしてやって，期待通りの動作をすることを確認しておこう．

instance HasCodableKey User where
    type EncodedKey User = EncodedUserKey
    wrapEncodedKey = EncodedUserKey
    unwrapEncodedKey = unEncodedUserKey
    salt = "this is my salt"

instance HasCodableKey Team where
    type EncodedKey Team = EncodedTeamKey
    wrapEncodedKey = EncodedTeamKey
    unwrapEncodedKey = unEncodedTeamKey
    salt = "another salt"

> encodeKey $ UserKey 42
EncodedUserKey {unEncodedUserKey = "eP"}

> decodeKey $ encodeKey $ UserKey 42
Just (UserKey {unUserKey = 42})

> encodeKey $ TeamKey 42
EncodedTeamKey {unEncodedTeamKey = "5Q"}

> decodeKey $ encodeKey $ TeamKey 42
Just (TeamKey {unTeamKey = 42})

今回のコードの全文は以下のとおりである．

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}

module Lib where

import Data.ByteString (ByteString)
import Web.Hashids (encodeUsingSalt, decodeUsingSalt)

data User
    = User
    { userName :: String
    , userAge  :: Int
    }

newtype UserKey = UserKey { unUserKey :: Int } deriving (Eq, Show)

data Team
    = Team
    { teamName  :: String
    , teamUsers :: [User]
    }

newtype TeamKey = TeamKey { unTeamKey :: Int } deriving (Eq, Show)

-- 何かしらのkeyを持つことを表す型クラス
class HasKey a where
    type Key a = (r :: *) | r -> a -- aをとってkeyを返す型レヴェル関数（e.g. Key User = UserKey）
    wrapKey   :: Int -> Key a
    unwrapKey :: Key a -> Int

instance HasKey User where
    type Key User = UserKey
    wrapKey = UserKey
    unwrapKey = unUserKey

instance HasKey Team where
    type Key Team = TeamKey
    wrapKey = TeamKey
    unwrapKey = unTeamKey

newtype EncodedUserKey = EncodedUserKey { unEncodedUserKey :: ByteString } deriving (Eq, Show)

newtype EncodedTeamKey = EncodedTeamKey { unEncodedTeamKey :: ByteString } deriving (Eq, Show)

-- Keyをhashidsでエンコード・デコードできることを表す型クラス
class HasKey a => HasCodableKey a where
    -- エンコードした後のkey（e.g. EncodedUserKey）
    type EncodedKey a = (r :: *) | r -> a

    wrapEncodedKey   :: ByteString -> EncodedKey a
    unwrapEncodedKey :: EncodedKey a -> ByteString

    -- saltは変えられるようにしておく
    salt :: ByteString

    encodeKey :: Key a -> EncodedKey a
    encodeKey key =
        let n = unwrapKey key
            bs = encodeUsingSalt (salt @a) n
        in wrapEncodedKey bs

    decodeKey :: EncodedKey a -> Maybe (Key a)
    decodeKey encodedKey =
        let bs = unwrapEncodedKey encodedKey
            ns = decodeUsingSalt (salt @a) bs
        in case ns of
            [n] -> Just (wrapKey n)
            _   -> Nothing

instance HasCodableKey User where
    type EncodedKey User = EncodedUserKey
    wrapEncodedKey = EncodedUserKey
    unwrapEncodedKey = unEncodedUserKey
    salt = "this is my salt"

instance HasCodableKey Team where
    type EncodedKey Team = EncodedTeamKey
    wrapEncodedKey = EncodedTeamKey
    unwrapEncodedKey = unEncodedTeamKey
    salt = "another salt"

脚注#

*1: FAQにも書いているとおり，デコードができるので決してハッシュアルゴリズムを用いているわけではないが，googlabilityのために"hash"という語を選んでいるそうだ．

*2: ここの記法は少し調べるのに苦労した部分だった．Microsoftの論文などに当たってみると，associated typeはopen type familiesの場合の特殊な例であるから，同じ記法を使うし議論を省略する，といった内容が書かれていた．