PureScriptでClean Architecture - Tagless Final編
はじめに
私はこれまでいかにPureScriptでClean Architectureを実現するか模索し続けてきたわけですが、また新しい方法を考えたので紹介したいと思います。
この記事の構成
この記事は大きく3つのセクションに分かれています。
それなりに長い記事となっておりますので、目的に応じて目次から興味のあるところまで飛んでいただけたらと思います。
- 私がこの記事で紹介する手法にたどり着くまでの流れ
- 具体的にどうやってTagless FinalでClean Architectureを実現するのかの説明
- この手法を用いて私が作った4層の小さなサンプルアプリケーションのコードを見る
説明しないこと
文章量が長くなりすぎるため、以下の説明は割愛させてください。
- Tagless Finalについての詳細な解説(簡単に説明はします)
- Clean Architectureについての解説
- PureScriptの基礎的な部分、ライブラリの使い方など。
これまでのあらすじ
Clean Architectureを実現する上でクリアしないといけないところ
PureScriptに限った話ではないのですが、Clean Architectureは依存が単方向なLayerd Architectureなので、逆方向のレイヤーにアクセスするためには依存性を逆転させる必要があります。
この「依存性の逆転」をPureScriptでどう実現するかが私の中での最大の課題で、この課題を解決するため長い長い探求の旅を続けてきたのでした。
その旅の思い出をちょっとふりかえってみたいと思います。
関数に関数を渡そう
というのが最初に思いついた方法でした。
関数の定義をしたRecordを内側のレイヤーに定義しておき、そのRecordの生成自体は外側のレイヤーに定義し、実行するとき生成したRecordを関数に渡す、というのがこの方式です。
-- Recordに関数を定義(内側のレイヤーに置く)
type Functions = {
function1 :: String -> Int,
function2 :: Int -> Unit
}
-- ↑のRecordを使う関数(これも内側のレイヤーに存在)
exec :: Functions -> String -> Unit
exec f s = do
let v = f.functions1 s
in f.function2 v
-- Recordを生成(外側のレイヤーに置く)
functions :: Functions
functions = {
function1: \s -> "",
function2: \n -> unit
}
-- 実行(これも外側のレイヤー)
doExec :: String -> Unit
doExec s = exec functions
この方法は単純でわかりやすくはあったのですが、言語の『らしさ』を引き出せていない気がしていました。
Tagless Finalでやれないか
ということも実は当時考えていました（↑の記事の最後の方に書いてます）。
Tagless Finalとは、型クラスを用いてDSLを構築する手法で、今回の文脈でいうといい感じにインタフェースと実装を分離することができそうだったので、うまく使えないか試していたのです。
が、そのときはOrphan Instance（孤立したインスタンス）の問題があって断念したのでした。
どういうことかというと型クラスを定義したモジュールではないモジュールで、これまた別のモジュールの型を型クラスのインスタンスにしようとするとコンパイルエラーになってしまうのです。
例えば次のような型クラスがあったとします。
class Monad m <= XPort m where
...
この型クラスのインスタンスを次のように定義しようとするとコンパイルエラーになります。
-- XPortもMaybeもここの定義とは別のモジュールで定義されている
instance instanceX :: XPort Maybe where
...
-- InterfaceAがこの定義と同じモジュールに定義されていても駄目
instance instanceX :: (InterfaceA m, InterfaceB m) => XPort m where
...
これは困った、どうしたらいいんだ？
なぜOrphan Instance問題が解決できなかったのか
(ここはコメントいただいて加筆した部分になります)
Orphan Instanceを解決する方法は、型クラスとインスタンスの定義を同じモジュールにする以外に、newtypeでラッパー型を作るという方法があります。
例えば次のような型クラスがあったとします。
class InterfaceX m where
functionX :: String -> m String
この型クラスInterfaceXのMaybeインスタンスを別モジュールに定義するのですが、Maybeを直接インスタンスにするのではなく、newtypeで新たな型に包んだいわゆるラッパーを作るのです。
こうすると、(このモジュールで定義された新たな型をインスタンスにすることになるので)Orphan Instanceにならなくなります。
newtype MaybeWrapper a = MaybeWrapper (Maybe a)
instance implX :: InterfaceX MaybeWrapper where
functionX = undefined
では型クラスにMonadの制約がついていたらどうでしょうか（Tagless Finalだとよくあるケースです）。
class Monad m <= InterfaceX m where
functionX :: String -> m String
この場合さきほどのMaybeWrapperは中身のMaybeはMonadの制約を満たしているもののMaybeWrapper自身はMonadの制約を満たさないのでコンパイルエラーになります。
この問題に対しては、derive newtype instanceを使うことで対処できますが、元々のMaybeの能力をフルに使えていない感じがします。また型クラスの制約がMonadAffだったりしたら更にderiveが増えます。
newtype MaybeWrapper a = MaybeWrapper (Maybe a)
derive newtype instance functorMaybeWrapper :: Functor MaybeWrapper
derive newtype instance applyMaybeWrapper :: Apply MaybeWrapper
derive newtype instance applicativeMaybeWrapper :: Applicative MaybeWrapper
derive newtype instance bindMaybeWrapper :: Bind MaybeWrapper
instance Monad MaybeWrapper
instance implX :: InterfaceX MaybeWrapper where
functionX = undefined
deriveを沢山書くことに関しては、「そういうもの」として許容できるかもしれませんが、もう一つ問題があります。
次のように型クラス InterfaceX と InterfaceY があったとします。
class Monad m <= InterfaceX m where
functionX :: String -> m String
class Monad m <= InterfaceY m where
functionY :: String -> m Int
そしてこれら2の型クラスを組み合わせて用いる関数があります。
import InterfaceX (class InterfaceX, functionX)
import InterfaceY (class InterfaceY, functionY)
execute
:: forall m
. Monad m
=> InterfaceX m
=> InterfaceY m
=> String
-> m Int
execute s = do
x <- functionX s
functionY x
この関数を実行するために、2つの型クラスのインスタンスを作ってみます。
敢えてまず問題ない書き方をします。
(いま実装の中身に関心がないためundefinedを使っています)
import Prelude
import Data.Maybe (Maybe)
import Gateway.InterfaceX (class InterfaceX)
import Gateway.InterfaceY (class InterfaceY)
import Undefined (undefined)
newtype MaybeWrapper a = MaybeWrapper (Maybe a)
derive newtype instance functorMaybeWrapper :: Functor MaybeWrapper
derive newtype instance applyMaybeWrapper :: Apply MaybeWrapper
derive newtype instance applicativeMaybeWrapper :: Applicative MaybeWrapper
derive newtype instance bindMaybeWrapper :: Bind MaybeWrapper
instance Monad MaybeWrapper
instance implX :: InterfaceX MaybeWrapper where
functionX = undefined
instance implY :: InterfaceY MaybeWrapper where
functionY = undefined
runMaybeWrapper :: forall a. MaybeWrapper a -> Maybe a
runMaybeWrapper (MaybeWrapper m) = m
準備ができました。executeは次のように実行できます。
import Impl (runMaybeWrapper)
doExecute :: String -> Maybe Int
doExecute s = runMaybeWrapper $ execute s
これは問題ない例なので大丈夫です。
ではどういうとき問題になるかというと、上記のInterfaceXとInterfaceYのインスタンスを別々のモジュールに定義したときです。
newtypeラッパーは当然モジュールごとに必要になります。
import Prelude
import Data.Maybe (Maybe)
import InterfaceX (class InterfaceX)
import Undefined (undefined)
newtype MaybeWrapperX a = MaybeWrapperX (Maybe a)
derive newtype instance functorMaybeWrapperX :: Functor MaybeWrapperX
derive newtype instance applyMaybeWrapperX :: Apply MaybeWrapperX
derive newtype instance applicativeMaybeWrapperX :: Applicative MaybeWrapperX
derive newtype instance bindMaybeWrapperX :: Bind MaybeWrapperX
instance Monad MaybeWrapperX
instance implX :: InterfaceX MaybeWrapperX where
functionX = undefined
runMaybeWrapperX :: forall a. MaybeWrapperX a -> Maybe a
runMaybeWrapperX (MaybeWrapperX m) = m
import Prelude
import Data.Maybe (Maybe)
import InterfaceY (class InterfaceY)
import Undefined (undefined)
newtype MaybeWrapperY a = MaybeWrapperY (Maybe a)
derive newtype instance functorMaybeWrapperY :: Functor MaybeWrapperY
derive newtype instance applyMaybeWrapperY :: Apply MaybeWrapperY
derive newtype instance applicativeMaybeWrapperY :: Applicative MaybeWrapperY
derive newtype instance bindMaybeWrapperY :: Bind MaybeWrapperY
instance Monad MaybeWrapperY
instance implY :: InterfaceY MaybeWrapperY where
functionY = undefined
runMaybeWrapperY :: forall a. MaybeWrapperY a -> Maybe a
runMaybeWrapperY (MaybeWrapperY m) = m
では、この場合execute関数をどうやって実行すればよいでしょうか。
まずうまくいった場合と同じようにexecute sの結果をrunMaybeWrapperXに渡してみましょう。
doExecute :: String -> Maybe Int
doExecute s = runMaybeWrapperX $ execute s
するとコンパイルエラーになります。
executeが返してくるm IntのmにはInterfaceXとInterfaceY両方の制約がありますが、MaybeWrapperXはInterfaceYのインスタンスではないからです。
MaybeWrapperX
No type class instance was found for
InterfaceY MaybeWrapperX
じゃあインスタンスにしてやろうじゃないか、とこのように定義するとOrphan Instanceになります。
instance implYX :: InterfaceY MaybeWrapperX where
functionY = undefined
ではrunMaybeWrapperYを使った場合はどうかというと結果は同じで、今度はMaybeWrapperYがInterfaceXのインスタンスではないのでコンパイルエラーになります。
doExecute :: String -> Maybe Int
doExecute s = runMaybeWrapperY $ execute s
これが「問題のある」例です。
前述した通り複数の型クラスのインスタンス定義を同じモジュールにまとめてしまえばいいのですが、Clean Architectureを実現する上では、全然責務の事なる型クラスのインスタンスを同一のモジュールに定義するわけにはいかず・・・・・・
ということで、これでは依存性を逆転できない、どうしたらいいんだと終わりのない型パズルの世界に迷いこんでしまったかの如く懊悩した私はTagless Finalでやることを諦め、別の方法を模索しはじめたのでした。
Extensible Effectsを使おう
次に思いついたのはExtensible Effectsを使う方法でした。
Extensible EffectsはFreeモナドを利用しており、インタフェース的な部分と実装を分離できるのです。
以下が上記の記事の例です（このコードの詳細はこの後の説明にあまり関係ないので真面目に見なくていいです）。
type TodoPortType = {
findTodos :: UserId -> Aff (Either Error Todos)
}
data TodoPort a
= FindTodos UserId ((Either Error Todos) -> a)
-- The following is almost boilerplate
derive instance todoPortF :: Functor TodoPort
type TODO_PORT r = (todoPort :: TodoPort | r)
_todoPort = Proxy :: Proxy "todoPort"
findTodos :: forall r. UserId -> Run (TODO_PORT + r) (Either Error Todos)
findTodos userId = lift _todoPort (FindTodos userId identity)
runPort :: forall r. TodoPortType -> Run (TODO_PORT + AFF + r) ~> Run (AFF + r)
runPort t run = interpret (on _todoPort (todoPortHandler t) send) run
todoPortHandler :: forall r. TodoPortType -> TodoPort ~> Run (AFF + r)
todoPortHandler t r = case r of
FindTodos userId next -> do
todos <- liftAff $ t.findTodos userId
pure $ next todos
type TodoJson = {
title :: String,
completed :: Boolean
}
type TodosJson = Array TodoJson
createTodoPort :: TodoPortType
createTodoPort = { findTodos: findTodos }
findTodos :: UserId -> Aff (Either Error Todos)
findTodos (UserId id) = do
res <- get string $ "https://jsonplaceholder.typicode.com/users/" <> show id <> "/todos"
case res of
Left err -> do
pure $ Left $ Error $ "GET /api response failed to decode: " <> printError err
Right response -> do
case readJSON response.body of
Right (todos :: TodosJson) -> do
pure $ Right $ todos <#> (\{title, completed} -> todo (TodoTitle title) if completed then Completed else InCompleted)
Left e -> do
pure $ Left $ Error $ "Can't parse JSON. " <> show e
この方法を思いついたときは一定満足していたのですが、その後Extensible Effects自体の解説記事を書いたり、Three Layer Cakeの記事を書いたりと色々調べる中で、そもそも「難しい」ということが気になってきました。
自分が書く分にはいいけど、Extensible EffectsとかFreeモナドなんて全然知らんという人におすすめしたとして、いきなりは書けんだろうと。
Tagless Final再び
Extensible Effects は難しいので、やはり単純なTagless Final方式を使いたい。
ということで次は一度断念したTagless Final形式でどうにかできないか再度考えてみて試行錯誤した結果、ある程度形になったので記事にする運びとなりました。
Tagless Final で Clean Architecture を実現する
Tagless Final についてかる〜く説明
そもそもTagless Finalとはどのような手法なのでしょうか？
先に簡単に説明しておきます。
次の型クラスの定義を見てください。
class Monad m <= TaglessFinalA m where
functionA :: String -> m Int
class Monad m <= TaglessFinalB m where
functionB :: Int -> m Boolean
型変数としてmが定義されています。
そして型クラスに定義された関数はこのmを返しています。
後ほどわかりますが、この「mを返している」というのが重要な部分です。
今回の例ではこのmにMonadであるという制約をつけています。
ではこの型クラスを使う関数を見てみましょう。
execute
:: forall m
. TaglessFinalA m
=> TaglessFinalB m
=> String
-> m Boolean
execute s = do
i <- functionA s
functionB i
全称量化されたmに対し、上記で定義した型クラス2の制約がつけられており、返る型もm Boolean型となっています。
重要なのはこの「型制約がついたm」を返すことになっているが故に、型クラスの関数をすべて呼び出せるということです。
では、型クラスのインスタンスを定義してexecuteを呼び出してみましょう。
試しにMaybeをインスタンスとしてみます。
instance implTaglessFinalA :: TaglessFinalA Maybe where
functionA s = fromString s
instance implTaglessFinalB :: TaglessFinalB Maybe where
functionB i = pure $ i /= 0
ではexecuteを使ってみましょう。
doExecute :: String
doExecute = maybe "false" show (execute "1")
true
Tagless Finalを使いつつ依存性を逆転させる方法
型クラスをインタフェースのように使えば依存性の逆転ができそうな気がしてきました。
しかし前述したようにOrphan Instanceの問題があります。
例えば上記の例のインスタンス定義を型クラスと別のモジュールで行なった場合コンパイルエラーになります。
ということでこのOrphan Instance問題をクリアしなければなりません。
この問題に対し、今回私がとるアプローチはこうです。
- 型クラスの関数と同じシグニチャの関数を定義したRecord型を定義する
- インスタンスは型クラスと同じモジュールに定義する
- インスタンスの型はReaderT型とする
- ReaderT型の型変数は上記のRecord型とする
- インスタンスの関数の処理は上記のRecordの関数に委譲する
- Record型の値を生成するのは外側のレイヤーにある別モジュールとする
- Record型の値を使って型クラスの関数をrunRederTで呼び出すのも外側のレイヤーとする
これにより、型クラスを使う側にRecord型を登場させずに、型制約によって依存を表現するできるようになります。
表層としてはTagless Finalの恩恵を享受しつつ、依存性を逆転させられ、かつTDDで開発できます。
ちなみにRecord型を使っているのは外側から依存を注入するのにやりやすいからです。
よくわからないと思うので、具体のコードで説明しましょう。
型クラスは先ほどの例と同じものを用います。
また、↑の項番をコメントとして差し込んでいます。
import Prelude
import Control.Monad.Reader (ReaderT(..))
import Type.Equality (class TypeEquals, to)
class Monad m <= TaglessFinalA m where
functionA :: String -> m Int
class Monad m <= TaglessFinalB m where
functionB :: Int -> m Boolean
-- 1. 型クラスの関数と同じシグニチャの関数を定義したRecord型を定義する
type TaglessFinalAFunction m r = { functionA :: String -> m Int | r }
type TaglessFinalBFunction m r = { functionB :: Int -> m Boolean | r}
-- 2. インスタンスは型クラスと同じモジュールに定義する
-- 3. インスタンスの型はReaderT型とする
-- 4. ReaderT型の型変数は上記のRecord型とする
instance implTaglessFinalA
:: (Monad m, TypeEquals t (TaglessFinalAFunction m r))
=> TaglessFinalA (ReaderT t m) where
-- 5. インスタンスの関数の処理は上記のRecordの関数に委譲する
functionA s = ReaderT \t -> (to t).functionA s
instance implTaglessFinalB
:: (Monad m, TypeEquals t (TaglessFinalBFunction m r))
=> TaglessFinalB (ReaderT t m) where
functionB i = ReaderT \t -> (to t).functionB i
execute
:: forall m
. TaglessFinalA m
=> TaglessFinalB m
=> String
-> m Boolean
execute s = do
i <- functionA s
functionB i
いくつか補足します。
まずRecord型は拡張可能にしています。これは後ほどRecordをマージするためです。
次に、ReaderTを使っているところは疑問はないと思いますが、TypeEqualsのところは気になるでしょうから説明します。
これはRecordを型クラスのインスタンスにすることができないためです。
この問題をクリアするためにTypeEqualsで制約をかけ間接的にインスタンスにしているのです。
to関数でRecordを取得し、委譲する関数を呼び出しています。
このあたり冗長と思われるかもしれませんが、そのあたりは緩和する方法を考えてあります。
ただ認知不可を減らすためここでは愚直に書いています。
次はRecordの値を作ります。型は先ほど同様Maybeとします。
-- 5. Record型の値を生成するのは外側のレイヤーにある別モジュールとする
aFunction :: TaglessFinalAFunction Maybe ()
aFunction = { functionA: \s -> fromString s }
bFunction :: TaglessFinalBFunction Maybe ()
bFunction = { functionB: \i -> pure $ i /= 0 }
そしてexecuteを使う箇所はこうです。
buildやmergeを使ってRecordをマージしてrunReaderTに渡しています。
import Control.Monad.Reader (runReaderT)
import Data.Int (fromString)
import Data.Maybe (Maybe, maybe)
import Record.Builder (build, merge)
-- 6. Record型の値を使って型クラスの関数をrunRederTで呼び出すのも外側のレイヤーとする
doExecute :: String
doExecute = do
let
functions = build (merge (aFunction)) bFunction
x = runReaderT (execute "1") functions
maybe "false" show x
これで完全にインタフェース部分と実装部分を分離でき、依存性の逆転が可能になりました。
runReaderT (execute "1") functionsのfunctionsにモック関数を用いることでテストも容易に作成できますし、テストの単位も細かくできます。
というかTDDで開発するためにこうやって依存性を注入しているといってもいいくらいです。
関係性の視覚化
色々な要素が登場したので関係性を把握しやすくするための図を用意しました。
こちらを御覧ください。
白い線は境界を表すもので、矢印は参照の方向を表しています。
関係性が強いものは同じ色にしてあります。
依存関係を図解したもの
依存関係を単方向にしつつ、依存性が逆転できていますね。
上記の図をClean Architectureに登場する要素に置き換えてみます。
要素の色は例のClean Architectureの同心円の色に合わせてみました。
ボイラープレートを減らすには
実用していく上で気になるところがあります。
それは一定ボイラープレートが出現するところです。
これはExtensible Effectsを利用しようが、Freeモナドを利用しようが出てくるので、メリットを享受するためには仕方ないと目を瞑りたいところですが、削減できるものなら削減したいです。
さすがに型クラスの定義とかRecordとかのインタフェース部分はどうしようもないのですが、一箇所やりようがある部分があります。
ReaderTのインスタンス定義で、処理をRecordの関数に委譲しているところです。
instance implTaglessFinalA
:: (Monad m, TypeEquals t (TaglessFinalAFunction m r))
=> TaglessFinalA (ReaderT t m) where
functionA s = ReaderT \t -> (to t).functionA s
シグニチャがまったく一緒なのでいかにもイータ変換してコード量を減らせそうです。
減らせそうなのですが
functionA = \s -> ReaderT \t -> (to t).functionA s
とか
functionA = ReaderT <<< (\s t -> (to t).functionA s)
とかしないとイータ変換可能な形にならず、これだとあまり旨くないです。
ってことでイータ変換をサポートするライブラリを作っちゃいました（元々これがやりたくて作り出した）。
このライブラリにはreaderTという関数があるので、これを使うとコードは次のようになります。
import Data.ReaderTEtaConversionTransformer (readerT)
instance implTaglessFinalA
:: (Monad m, TypeEquals t (TaglessFinalAFunction m r))
=> TaglessFinalA (ReaderT t m) where
functionA = readerT _.functionA
なーーーんも考えずに、_.functionAとRecordの関数名を書くだけです。
地味な効能ですが自明なコードを何度も書かなくて済むならそれにこしたことはないでしょう。
具体例
ではこれでアプリケーションを作るとどうなるんだという具体例をお見せしましょう。
コードの全体はここにあります。
GithubからPureScriptのリポジトリを検索するサンプルです。
（見た目は気にしないでください。お願いします。アドベントカレンダーに間に合わせたかったんです。）
レイヤーは4層構造で、次のように責務ごとに要素分解しています。
- domains
- usecases
- controllers
- gateways
- presenters
- drivers
- view
- state
Domain
まずはDomainです。
newtypeでキッチリ型を定義しています。
今回のケースでは特にドメインロジックを定義していません。
import Data.Date (Date)
import Data.Maybe (Maybe)
newtype GitHubRepositories
= GitHubRepositories (Array GitHubRepository)
newtype GitHubRepository
= GitHubRepository
{ name :: GitHubRepositoryName
, url :: GitHubRepositoryUrl
, owner :: GitHubRepositoryOwner
, updateDate :: GitHubRepositoryUpdateDate
}
newtype GitHubRepositoryName = GitHubRepositoryName String
newtype GitHubRepositoryUrl = GitHubRepositoryUrl String
newtype GitHubRepositoryOwner = GitHubRepositoryOwner String
newtype GitHubRepositoryUpdateDate = GitHubRepositoryUpdateDate (Maybe Date)
derive newtype instance showRepositories :: Show GitHubRepositories
derive newtype instance eqRepositories :: Eq GitHubRepositories
derive newtype instance showRepository :: Show GitHubRepository
derive newtype instance eqRepository :: Eq GitHubRepository
derive newtype instance showName :: Show GitHubRepositoryName
derive newtype instance eqName :: Eq GitHubRepositoryName
derive newtype instance showUrl :: Show GitHubRepositoryUrl
derive newtype instance eqUrl :: Eq GitHubRepositoryUrl
derive newtype instance showOwner :: Show GitHubRepositoryOwner
derive newtype instance eqOwner :: Eq GitHubRepositoryOwner
derive newtype instance showDate :: Show GitHubRepositoryUpdateDate
derive newtype instance eqDate :: Eq GitHubRepositoryUpdateDate
View
Viewからの抜粋です。「Search」ボタンのイベントにより、入力されたリポジトリ名を引数にControllerの関数を呼び出しています。
ロジックがまるでないので非常にスッキリサッパリしています。
import Controller.GitHubRepositoryController (searchRepositoryByName)
handleAction :: forall o m. MonadAff m => Action -> H.HalogenM SearchGitHubRepositoryState Action () o m Unit
handleAction = case _ of
SetSearchRepositoryName searchRepositoryName -> do
H.modify_ (_ { searchRepositoryName = searchRepositoryName })
SearchRepository event -> do
H.liftEffect $ Event.preventDefault event
-- controllerの関数を実行
searchRepositoryByName =<< H.gets _.searchRepositoryName
Controller
続いてControllerです。
内側のレイヤーの関数だけを参照しており、UseCaseの関数を実行するために依存する関数を用意し、runReaderTを使ってDIしつつUseCaseを実行しています。
import Control.Monad.Reader (runReaderT)
import Control.Monad.State (class MonadState)
import Domain.GitHubRepository (GitHubRepositoryName(..))
import Driver.GitHubApiDriver (gitHubRepositoryGatewayPortFunction)
import Driver.StateDriver (presenterPortFunction)
import Effect.Aff.Class (class MonadAff)
import Gateway.GitHubRepositoryGateway (gitHubRepositoryPortFunction)
import Presenter.GitHubRepositoryPresenter (gitHubRepositoryPresenterPortFunction)
import Record.Builder (build, merge)
import State.SearchGitHubRepositoryState (SearchGitHubRepositoryState)
import UseCase.SearchGitHubRepositoryUseCase (execute)
searchRepositoryByName
:: forall m
. Monad m
=> MonadAff m
=> MonadState SearchGitHubRepositoryState m
=> String
-> m Unit
searchRepositoryByName name = do
let
gf = gitHubRepositoryPortFunction gitHubRepositoryGatewayPortFunction
pf = gitHubRepositoryPresenterPortFunction presenterPortFunction
functions = build (merge (gf)) pf
runReaderT (execute (GitHubRepositoryName name)) functions
UseCase
こちらがUseCaseです。型クラスの制約を利用して関数を呼び出しています。
import Data.Either (either)
import Domain.GitHubRepository (GitHubRepositoryName)
import UseCase.Port (class GitHubRepositoryPort, class GitHubRepositoryOutputPort, searchByName, setErrorMessage, setLoading, setRepositories)
execute
:: forall m
. GitHubRepositoryPort m
=> GitHubRepositoryOutputPort m
=> GitHubRepositoryName
-> m Unit
execute name = do
setLoading true
searchByName name >>= either setErrorMessage setRepositories
setLoading false
型クラスおよび委譲する関数が定義されたRecordがこちらです。
import Control.Monad.Reader (ReaderT)
import Data.Either (Either)
import Data.ReaderTEtaConversionTransformer (readerT)
import Domain.Error (Error)
import Domain.GitHubRepository (GitHubRepositories, GitHubRepositoryName)
import Type.Equality (class TypeEquals)
class Monad m <= GitHubRepositoryPort m where
searchByName :: GitHubRepositoryName -> m (Either Error GitHubRepositories)
class Monad m <= GitHubRepositoryOutputPort m where
setRepositories :: GitHubRepositories -> m Unit
setLoading :: Boolean -> m Unit
setErrorMessage :: Error -> m Unit
type GitHubRepositoryPortFunction m r = {
searchByName :: GitHubRepositoryName -> m (Either Error GitHubRepositories) | r
}
type GitHubRepositoryOutputPortFunction m r = {
setRepositories :: GitHubRepositories -> m Unit,
setLoading :: Boolean -> m Unit,
setErrorMessage :: Error -> m Unit
| r
}
instance portReaderT ::
(Monad m, TypeEquals f (GitHubRepositoryPortFunction m r)) =>
GitHubRepositoryPort (ReaderT f m) where
searchByName = readerT _.searchByName
instance outputPortReaderT ::
(Monad m, TypeEquals f (GitHubRepositoryOutputPortFunction m r)) =>
GitHubRepositoryOutputPort (ReaderT f m) where
setRepositories = readerT _.setRepositories
setLoading = readerT _.setLoading
setErrorMessage = readerT _.setErrorMessage
テストもあります。というかTDDで開発しやすいからこのようなことをしているわけで、当然テスト側から書いています。
runReaderTで渡す関数群はすべてモック関数です。
spec :: Spec Unit
spec = do
describe "Search GitHub Repository By Repository Name" do
it "Successful searched" do
let
repositories = GitHubRepositories []
name = GitHubRepositoryName "name"
-- mocks
setLoading = mock $ any@Boolean :> pure@Aff unit
searchByName = mock $ name :> pure@Aff (Right repositories)
setRepositories = mock $ any :> pure@Aff unit
-- sut
_ <- runReaderT (execute name) {
searchByName: fun searchByName,
setRepositories: fun setRepositories,
setLoading: fun setLoading,
setErrorMessage: mockFun $ any@Error :> pure@Aff unit
}
-- verify
setRepositories `hasBeenCalledWith` repositories
setLoading `hasBeenCalledInOrder` [true, false]
Gateway
続いてGatewayです。
UseCaseで定義していたRecord(GitHubRepositoryPortFunction)の値を返しています。
その際、さらに依存性を逆転させてGatewayの外側のレイヤーにアクセスするためのRecord(GitHubRepositoryGatewayPortFunction)を使っています。
これはすぐ後で出てきます。
それよりここではsearchByName関数に着目したいです。
この関数はまた型クラスの制約を利用してドメインへの変換処理を行っています。
import Control.Monad.Reader (runReaderT)
import Data.Date (Date)
import Data.Either (Either(..), either)
import Data.JSDate (parse, toDate)
import Data.Maybe (Maybe)
import Data.Traversable (traverse)
import Domain.Error (Error(..))
import Domain.GitHubRepository (GitHubRepositories(..), GitHubRepository(..), GitHubRepositoryName(..), GitHubRepositoryOwner(..), GitHubRepositoryUpdateDate(..), GitHubRepositoryUrl(..))
import Effect.Aff.Class (class MonadAff)
import Effect.Class (liftEffect)
import Gateway.Port (class GitHubRepositoryGatewayPort, SearchResult, GitHubRepositoryGatewayPortFunction)
import Gateway.Port as Port
import UseCase.Port (GitHubRepositoryPortFunction)
gitHubRepositoryPortFunction
:: forall m
. MonadAff m
=> GitHubRepositoryGatewayPortFunction m
-> GitHubRepositoryPortFunction m ()
gitHubRepositoryPortFunction f = {
searchByName: run <<< searchByName
}
where
run = flip runReaderT f
searchByName
:: forall m
. MonadAff m
=> GitHubRepositoryGatewayPort m
=> GitHubRepositoryName
-> m (Either Error GitHubRepositories)
searchByName (GitHubRepositoryName name) = do
Port.searchByName name >>= either
(pure <<< Left <<< Error)
(pure <<< Right <<< GitHubRepositories <=< traverse toRepository <<< _.items)
where
toRepository :: SearchResult -> m GitHubRepository
toRepository result = do
d <- dateFromString result.updated_at
pure $ GitHubRepository {
name: GitHubRepositoryName result.full_name,
url: GitHubRepositoryUrl result.html_url,
owner: GitHubRepositoryOwner result.owner.login,
updateDate: GitHubRepositoryUpdateDate d
}
dateFromString :: String -> m (Maybe Date)
dateFromString s = toDate <$> (liftEffect $ parse s)
依存性逆転用の型クラスとRecordがこちらです。
import Control.Monad.Reader (ReaderT)
import Data.Either (Either)
import Data.ReaderTEtaConversionTransformer (readerT)
import Type.Equality (class TypeEquals)
class Monad m <= GitHubRepositoryGatewayPort m where
searchByName :: String -> m (Either ErrorMessage SearchResults)
type GitHubRepositoryGatewayPortFunction m =
{ searchByName :: String -> m (Either ErrorMessage SearchResults) }
instance instancePortReaderT ::
(Monad m, TypeEquals f (GitHubRepositoryGatewayPortFunction m)) =>
GitHubRepositoryGatewayPort (ReaderT f m) where
searchByName = readerT _.searchByName
type ErrorMessage = String
type SearchResults = { items :: Array SearchResult }
type SearchResult = {
full_name :: String,
owner :: {
login :: String
},
html_url :: String,
updated_at :: String
}
Gatewayのテストがこちらです。
import Control.Monad.Reader (runReaderT)
import Data.Date (Date, canonicalDate)
import Data.Either (Either(..))
import Data.Enum (class BoundedEnum, toEnum)
import Data.Int (fromString)
import Data.Maybe (Maybe(..))
import Data.String (Pattern(..), split)
import Domain.Error (Error(..))
import Domain.GitHubRepository (GitHubRepositories(..), GitHubRepository(..), GitHubRepositoryName(..), GitHubRepositoryOwner(..), GitHubRepositoryUpdateDate(..), GitHubRepositoryUrl(..))
import Effect.Aff (Aff)
import Gateway.GitHubRepositoryGateway (searchByName)
import Test.PMock (mockFun, (:>))
import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions (shouldEqual)
spec :: Spec Unit
spec = do
describe "Search GitHub Repository By Repository Name" do
it "Success" do
let
output = {
items: [
{
full_name: "nameX",
owner: {
login: "user"
},
html_url: "http://url",
updated_at: "2023-12-17T14:17:49Z"
}
]
}
expected = Right $ GitHubRepositories [
GitHubRepository {
name: GitHubRepositoryName "nameX",
url: GitHubRepositoryUrl "http://url",
owner: GitHubRepositoryOwner "user",
updateDate: GitHubRepositoryUpdateDate $ parse "2023/12/17"
}
]
actual <- runReaderT (searchByName (GitHubRepositoryName "name")) {
searchByName: mockFun $ "name" :> pure@Aff (Right output)
}
actual `shouldEqual` expected
it "Failed" do
let expected = Left (Error "search error")
actual <- runReaderT (searchByName (GitHubRepositoryName "name")) {
searchByName: mockFun $ "name" :> pure@Aff (Left "search error")
}
actual `shouldEqual` expected
parse :: String -> Maybe Date
parse s = case split (Pattern "/") s of
[year, month, day] -> canonicalDate <$> (convert year) <*> (convert month) <*> (convert day)
_ -> Nothing
where
convert :: forall c. BoundedEnum c => String -> Maybe c
convert = toEnum <=< fromString
Presenter
構造はGatewayと同じで、UseCaseで定義していたRecordの値を返しています。
こちらもまたGatewayと同じく型クラスとRecordを使ってさらに依存性を逆転させています。
import Control.Monad.Reader (runReaderT)
import Data.DateTime.Instant (fromDate, toDateTime)
import Data.Either (either)
import Data.Formatter.DateTime (formatDateTime)
import Data.Maybe (Maybe(..), fromMaybe)
import Domain.Error (Error(..))
import Domain.GitHubRepository (GitHubRepositories(..), GitHubRepository(..), GitHubRepositoryName(..), GitHubRepositoryOwner(..), GitHubRepositoryUpdateDate(..), GitHubRepositoryUrl(..))
import Presenter.Port (class GitHubRepositoryPresenterPort, GitHubRepositoryPresenterPortFunction)
import Presenter.Port as Port
import State.SearchGitHubRepositoryState as State
import UseCase.Port (GitHubRepositoryOutputPortFunction)
gitHubRepositoryPresenterPortFunction
:: forall m
. Monad m
=> GitHubRepositoryPresenterPortFunction m
-> GitHubRepositoryOutputPortFunction m ()
gitHubRepositoryPresenterPortFunction f = {
setRepositories: run <<< setRepositories,
setLoading: run <<< setLoading,
setErrorMessage: run <<< setErrorMessage
}
where
run = flip runReaderT f
setRepositories
:: forall m
. Monad m
=> GitHubRepositoryPresenterPort m
=> GitHubRepositories
-> m Unit
setRepositories (GitHubRepositories r) = Port.setRepositories $ convert <$> r
convert :: GitHubRepository -> State.GitHubRepository
convert (GitHubRepository {
name: (GitHubRepositoryName n),
owner: (GitHubRepositoryOwner o),
url: (GitHubRepositoryUrl u),
updateDate: (GitHubRepositoryUpdateDate d) }) =
let
date = either (const Nothing) Just =<< format <$> toDate <$> d
in {
name: n,
owner: o,
url: u,
updateDate: fromMaybe "-" date
}
where
format = formatDateTime "YYYY/MM/DD"
toDate = toDateTime <<< fromDate
setLoading
:: forall m
. Monad m
=> GitHubRepositoryPresenterPort m
=> Boolean
-> m Unit
setLoading = Port.setLoading
setErrorMessage
:: forall m
. Monad m
=> GitHubRepositoryPresenterPort m
=> Error
-> m Unit
setErrorMessage (Error e) = Port.setErrorMessage e
型クラスとRecordがこちらです。
import Control.Monad.Reader (ReaderT)
import Data.ReaderTEtaConversionTransformer (readerT)
import State.SearchGitHubRepositoryState (GitHubRepositories, ErrorMessage)
import Type.Equality (class TypeEquals)
class Monad m <= GitHubRepositoryPresenterPort m where
setRepositories :: GitHubRepositories -> m Unit
setLoading :: Boolean -> m Unit
setErrorMessage :: ErrorMessage -> m Unit
type GitHubRepositoryPresenterPortFunction m = {
setRepositories :: GitHubRepositories -> m Unit,
setLoading :: Boolean -> m Unit,
setErrorMessage :: ErrorMessage -> m Unit
}
instance instancePortReaderT ::
(Monad m, TypeEquals f (GitHubRepositoryPresenterPortFunction m)) =>
GitHubRepositoryPresenterPort (ReaderT f m) where
setRepositories = readerT _.setRepositories
setLoading = readerT _.setLoading
setErrorMessage = readerT _.setErrorMessage
そしてこちらがテストになります。
import Control.Monad.Reader (runReaderT)
import Data.Date (Date, canonicalDate)
import Data.Enum (class BoundedEnum, toEnum)
import Data.Int (fromString)
import Data.Maybe (Maybe(..))
import Data.String (Pattern(..), split)
import Domain.Error (Error(..))
import Domain.GitHubRepository (GitHubRepositories(..), GitHubRepository(..), GitHubRepositoryName(..), GitHubRepositoryOwner(..), GitHubRepositoryUpdateDate(..), GitHubRepositoryUrl(..))
import Effect.Aff (Aff)
import Presenter.GitHubRepositoryPresenter (setErrorMessage, setLoading, setRepositories)
import Presenter.Port (GitHubRepositoryPresenterPortFunction)
import State.SearchGitHubRepositoryState (ErrorMessage)
import State.SearchGitHubRepositoryState as State
import Test.PMock (any, fun, hasBeenCalledWith, mock, mockFun, (:>))
import Test.Spec (Spec, describe, it)
spec :: Spec Unit
spec = do
describe "Presenter" do
it "setRepository" do
let
repositories = GitHubRepositories [
GitHubRepository {
name: GitHubRepositoryName "name",
url: GitHubRepositoryUrl "url",
owner: GitHubRepositoryOwner "owner",
updateDate: GitHubRepositoryUpdateDate $ parse "2023/12/18"
}
]
stateMock = mock $ any@State.GitHubRepositories :> pure@Aff unit
_ <- runReaderT (setRepositories repositories) defaultMockFunctions {
setRepositories = fun stateMock
}
stateMock `hasBeenCalledWith` [
{
name: "name",
url: "url",
owner: "owner",
updateDate: "2023/12/18"
}
]
it "setLoading" do
let
stateMock = mock $ any@Boolean :> pure@Aff unit
_ <- runReaderT (setLoading true) defaultMockFunctions {
setLoading = fun stateMock
}
stateMock `hasBeenCalledWith` true
it "setErrorMessage" do
let
stateMock = mock $ any@ErrorMessage :> pure@Aff unit
_ <- runReaderT (setErrorMessage $ Error "error") defaultMockFunctions {
setErrorMessage = fun stateMock
}
stateMock `hasBeenCalledWith` "error"
defaultMockFunctions :: GitHubRepositoryPresenterPortFunction Aff
defaultMockFunctions = {
setRepositories: mockFun $ any@State.GitHubRepositories :> pure@Aff unit,
setLoading: mockFun $ any@Boolean :> pure@Aff unit,
setErrorMessage: mockFun $ any@ErrorMessage :> pure@Aff unit
}
parse :: String -> Maybe Date
parse s = case split (Pattern "/") s of
[year, month, day] -> canonicalDate <$> (convert year) <*> (convert month) <*> (convert day)
_ -> Nothing
where
convert :: forall c. BoundedEnum c => String -> Maybe c
convert = toEnum <=< fromString
Driver
一番外側のレイヤーです。
まずGatewayに定義されていたRecordを返しているのがこちらです。
処理としてはAffJaxを使ってリクエストを投げ、結果のJSONをRecordに変換しています。
import Affjax.RequestHeader (RequestHeader(..))
import Affjax.ResponseFormat as ResponseFormat
import Affjax.Web (Request, defaultRequest, printError, request)
import Data.Array (snoc)
import Data.Either (Either(..), either)
import Data.EtaConversionTransformer ((<<|))
import Data.List.NonEmpty (foldl)
import Data.MediaType (MediaType(..))
import Data.String (joinWith)
import Effect.Aff.Class (class MonadAff, liftAff)
import Foreign (MultipleErrors, renderForeignError)
import Gateway.Port (ErrorMessage, GitHubRepositoryGatewayPortFunction, SearchResults)
import Simple.JSON (readJSON)
gitHubRepositoryGatewayPortFunction :: forall m. MonadAff m => GitHubRepositoryGatewayPortFunction m
gitHubRepositoryGatewayPortFunction = { searchByName }
searchByName :: forall m. MonadAff m => String -> m (Either ErrorMessage SearchResults)
searchByName = doRequest jsonToSearchResult <<| searchByNameRequest
doRequest :: forall m a. MonadAff m => (String -> Either MultipleErrors a) -> Request String -> m (Either ErrorMessage a)
doRequest f r = liftAff do
request r >>= either
(pure <<< Left <<< printError)
(either
(pure <<< Left <<< toErrorMessage)
(pure <<< Right)
<<< f <<| _.body)
toErrorMessage :: MultipleErrors -> String
toErrorMessage e = joinWith "\n" $ renderForeignError <$> foldl snoc [] e
searchByNameRequest :: String -> Request String
searchByNameRequest name = defaultRequest {
url = "https://api.github.com/search/repositories?q=" <> name <> "&language:purescript&sort=created&order=desc&page=1&per_page=10",
headers = [Accept $ MediaType "application/vnd.github+json"],
responseFormat = ResponseFormat.string
}
jsonToSearchResult :: String -> Either MultipleErrors SearchResults
jsonToSearchResult = readJSON
次にPresenterに定義されていたRecordを返す箇所です。
こちらはStateのmodify_を使っているだけです。
import Control.Monad.State (class MonadState, modify_)
import Data.Either (Either(..))
import Presenter.Port (GitHubRepositoryPresenterPortFunction)
import State.SearchGitHubRepositoryState (SearchGitHubRepositoryState)
presenterPortFunction :: forall m. MonadState SearchGitHubRepositoryState m => GitHubRepositoryPresenterPortFunction m
presenterPortFunction = {
setRepositories: \r -> modify_ (_ { repositories = Right r }),
setLoading: \loading -> modify_ (_ { isLoading = loading }),
setErrorMessage: \m -> modify_ (_ { repositories = Left m })
}
具体例の最後に
今回の例は実際の開発を意識して結構ガッツリの4層構造にしてみたのですが、いかがだったでしょうか。
アプリケーションの規模が小さいので冗長だと感じたかもしれませんし、Three Layer Cakeをご存知の方は、そちらの方がシンプルで良いと思ったかもしれません。
純粋な関数だけをテストする方針でいくのであれば私もThree Layer Cakeはいいと思いますが、私は処理の流れも含めてテストを書きたいし、責務を細かく分けたいし、TDDもやりたいのである程度はレイヤーを分けたいと思います（とはいえ4層ではなく3層にするかもしれない）。
あとがき
これまで色々試してきて、これで一旦自分としては一区切りついた感じがするので、次からはまた別の方面の知見を深めようかなぁと思います。
例えばHalogenを深ぼるとか。
ではまた。
Discussion
AdC投稿ありがとうございます
Orphan Instance の問題は newtype を使うと割と解決できたりしますね(使う側で newtype MyMonad = ... として class TaglessFinal MyMonad where ... として instance を書く)
ゆきくらげさん、記事を読んでいただきありがとうございます！
コメントもありがとうございます！
おっしゃるとおり Orphan Instance の問題は newtype で解決できますね（コンパイルエラーのメッセージにもnewtypeでラッパー作ればいいよと出てきますしね）
ただ今回の場合は次のように2点問題がありまして、それにより以前断念して今回の方法を考えたのです。
（別のケースでは newtype で解決できますね、という話でしたらすみません）
EffectとかAffとかをnewtypeでラップしてderive newtype instanceをいっぱい書けば解決するのですが、これはこれで手間だな、と。
mとして両方の制約を満たすnewtypeが必要になりますが、インスタンスの定義を別々のモジュールにしたい場合、そのようなnewtypeが作れない（共通して参照できる別のモジュールに作った場合またOrphan Instanceになってしまう）。と、ここまで書いていて最初Tagless Finalを断念した理由のところに↑みたいなことを書いておいた方がいいかなと思いました。