Haskell Persistentで直和型を含むデータをそのままデータベースに保存する

#はじめに
Haskell Persistentで直和型を含むデータをデータベースに保存する際、デフォルトではそのままデータベースに保存するのではなく、[公式ドキュメント](https://github.com/yesodweb/persistent/blob/master/docs/Persistent-entity-syntax.md#entity-level)のSumTypesにあるように、型X,Yに対し、直和型(X+Y)を保存するためにまずXとY単体のテーブルを作成し、そのどちらかのID値を保存する形で間接的に保存します。

しかしながら、この方法では後述するようなデメリットがあり、ID値を保存するための型に型変換等を行う必要があるなどプログラムの記述が複雑になります。

そこで本記事は、Haskell Persistentで直和型を含むデータも直積型などと同様に型変換等を行わずにそのまま1つのテーブルで保存する方法について記述します。

本記事のソースコードは[こちら](https://github.com/nekonistyle/persistent-sumType)にあります。


###直和型をID値でデータベースに保存するデメリット
直和型をID値でデータベースに保存する手法には以下のようなデメリットがあります。(X,Yを型とする。)

- 直和型(X+Y)をデータベースに保存するための(XId + YId)型に変換する必要がある。
- データを保存するときに2段階の手間がかかる。すなわち、(X+Y)型のデータを保存するためにまずXやYのデータを保存してそのID値を取得してから本体の直和型データを保存する必要がある。
- データを削除するときに本体の直和型データを削除しただけではXやYのデータが残ってしまう。すなわち、Garbage Collectionなどを用意する必要がある。


#Either型の場合
まずはEither型を含むデータをデータベースに保存する方法をみていきます。

まず、目標として以下のようなメインプログラムが通るようなものを作成します。


##メインプログラム
以下に定義される`Either`型を含む`MyData`型をデータベースに保存する場合を考えます。

```Haskell
--import文などは省略

type MySum = Either Int String

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
MyData
  value MySum
  deriving Show
|]

-- main
startApp :: IO ()
startApp = do
  pool <- readyPool dbPath migrateAll  -- ConnectionPoolの準備
  runSqlPool dbOperation pool

dbOperation :: DatabaseIO ()
dbOperation = do
  leftDataId <- insert $ MyData $ Left 4
  rightDataId <- insert $ MyData $ Right "hello"
  leftData <- get leftDataId
  rightData <- get rightDataId
  liftIO $ print leftData  -- Just (MyData {myDataValue = Left 4})
  liftIO $ print rightData -- Just (MyData {myDataValue = Right "hello"})

type DatabaseIO a = ReaderT SqlBackend IO a


-- ConnectionPool

dbPath :: FilePath
dbPath = "sqlite.db"

poolSize :: Int
poolSize = 5

readyPool :: FilePath -> Migration -> IO ConnectionPool
readyPool dbPath migration = do
  pool <- mkPool dbPath
  runSqlPool (runMigration migration) pool
  return pool

mkPool :: FilePath -> IO ConnectionPool
mkPool filePath =
  runStdoutLoggingT $ createSqlitePool (cs filePath) poolSize
```

`dbOperation :: DatabaseIO ()`が実際にデータベースにアクセスする部分で、`Either Int String`型である`Left 4`と`Right "hello"`をそのままデータベースに保存して、それを取り出しているコードになっています。

このコードは、公式ドキュメントのID値を保存する方法とは異なり、データベースのテーブルが本体の1つのみであり、Int型やString型をデータベースのID値に変換するのではなく直和型データのまま記述できるため、ここで型変換の記述を行う必要がありません。
また、後述するようにデータ削除時も不要なデータが残ることがなくなります。


しかしながら、このようなコードを通すためには以下のようなファイルを用意する必要があります。


##PersistFieldとPersistFieldSqlを作成
Persistentでは、データベースに保存する値を`PersistField`型に変換し、それをデータベース上で、データベースにおける型に対応する`PersistFieldSql`型として保存します。
したがって、直和型からこれら2つへの変換を与えます。

```haskell:MyPersistField.hs
{-# LANGUAGE TemplateHaskell #-}

module MyPersistField where

import Database.Persist
import Database.Persist.TH
import Database.Persist.Class
import Database.Persist.Sql
import Data.Text as T

-- PersistField
instance (PersistField a, PersistField b) => PersistField (Either a b) where
  toPersistValue (Left a) = PersistList [PersistBool True, toPersistValue a]
  toPersistValue (Right b) = PersistList [PersistBool False, toPersistValue b]
  fromPersistValue v =
    case fromPersistValue v of
      Right [PersistBool True,va] -> Left <$> fromPersistValue va
      Right [PersistBool False,vb] -> Right <$> fromPersistValue vb
      Left e -> Left e
      _ -> Left $ T.pack $ "Expected 2 item PersistList, recieved: " ++ show v

-- PersistFieldSql
instance (PersistFieldSql a, PersistFieldSql b) => PersistFieldSql (Either a b) where
  sqlType _ = SqlString
```

`PersistField`の方は`toPersistValue :: a -> PersistValue`と`fromPersistValue :: PersistValue -> Either Text a`を`fromPersistValue . toPersistValue`が`Right`と等価になるように定義します。
具体的には`PersistValue`型にはリストを表すコンストラクタがあるので、これを使って長さ2のリストを作り1つ目に`Left`であるか`Right`であるかの情報を表す`PersistBool`型、2つ目にその値を格納します。

`fromPersistValue`の定義の中で、`case fromPersistValue v of`という記述があり、引数`v`をそのままの形で再帰呼び出しを行なっているように見えますが、実はこの`case`文内の`fromPersistValue`は`PersistField (Either a b)`に対するものではなく`PersistField [PersistValue]`のものとして適用されます。
よって、その返り値の型は`Either Text [PersistValue]`となるため、それ以降の場合分けが可能になります。
このような記述は直積型に対する`PersistField (a,b)`の定義でも使われています。

また、`PersistFieldSql`の定義にあるように、直和型はデータベース上では直積型などと同様に`SqlString`で保存します。
例えば、Haskell上での`Left 4 :: Either Int String"`はデータベース上では`\"[true,4]\"`として保存されます。
あくまで1つの文字列として保存するので、直和型のデータを削除した場合にも不要なデータがデータベースに残ることはありません。

ここで定義したMyPersistField.hsをimportすると、先ほどのメインプログラムが動くようになります。


#一般の直和型の場合
上記の`Either`の例を応用して、一般の直和型に対しても`PersistField`と`PersistFieldSql`を定義します。

例として、以下のような異なる引数を持つ3つのコンストラクタを持つ直和型`MySumType`に対してこれらを定義します。

```haskell
data MySumType a b1 b2
  = Constructor1
  | Constructor2 a
  | Constructor3 b1 b2
  deriving Show
```

この`MySumType`型に対する`PersistField`、`PersistFieldSql`は以下のように定義できます。

```haskell
instance (PersistField a, PersistField b1, PersistField b2) => PersistField (MySumType a b1 b2) where
  toPersistValue Constructor1 =
    PersistList [PersistInt64 1]
  toPersistValue (Constructor2 a) =
    PersistList [PersistInt64 2, toPersistValue a]
  toPersistValue (Constructor3 b1 b2) =
    PersistList [PersistInt64 3, toPersistValue b1, toPersistValue b2]
  fromPersistValue v =
    case fromPersistValue v of
      Right [PersistInt64 1] -> Right Constructor1
      Right [PersistInt64 2,va] -> Constructor2 <$> fromPersistValue va
      Right [PersistInt64 3,vb1,vb2] ->
        Constructor3 <$> fromPersistValue vb1 <*> fromPersistValue vb2
      Left e -> Left e
      _ -> Left $ T.pack $ "Expected PersistList [1], [2,_] or [3,_,_], recieved: " ++ show v

instance (PersistFieldSql a, PersistFieldSql b1, PersistFieldSql b2) => PersistFieldSql (MySumType a b1 b2) where
  sqlType _ = SqlString
```

今回はコンストラクタの識別を`Int`型で行なっていますが、要は`fromPersistValue . toPersistValue`が`Right`と等価になるように定義できればどのように定義しても大丈夫です。
このように`PersistList`を利用して定義すれば、コンストラクタの引数が0でも複数でも対応ができます。

また、`PersistFieldSql`は`Either`の時と同様に`SqlString`として保存します。

これで以下のように`MuSumType`型をデータベースに保存することが可能です。

```haskell
type MySum3 = MySumType Int Int String

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
MyData3
  value MySum3
  deriving Show
|]

startApp :: IO ()
startApp = do
  pool <- readyPool dbPath migrateAll  -- ConnectionPoolの準備
  runSqlPool dbOperation3 pool

dbOperation3 :: MyDatabaseIO ()
dbOperation3 = do
  dataId1 <- insert $ MyData3 Constructor1
  dataId2 <- insert $ MyData3 $ Constructor2 4
  dataId3 <- insert $ MyData3 $ Constructor3 7 "world"
  data1 <- get dataId1
  data2 <- get dataId2
  data3 <- get dataId3
  liftIO $ print data1
  liftIO $ print data2
  liftIO $ print data3
-- Just (MyData3 {myData3Value = Constructor1})
-- Just (MyData3 {myData3Value = Constructor2 4})
-- Just (MyData3 {myData3Value = Constructor3 7 "world"})
```


#まとめ
Haskell Persistで直和型を含むデータを型変換などを行わずにそのままデータベースに保存する方法について記述しました。

この方法は公式ドキュメントのやり方とは異なり、直和型データを別の型に変換したり、データベースに2度アクセスする必要がなく、直接やりとりできる点に優位性があります。