HalogenのhandleActionでExtensible Effects(拡張可能作用)を使ってみる！

以前、Extensible Effectsを用いたClean Architectureなアプリケーションの記事を書きました。
https://zenn.dev/funnycat/articles/f012b0429d8304
上記はコマンドラインで実行する類の例でしたが、今回はフロントエンドでExtensible Effectsを使う例を紹介しようと思います。
ライブラリとしてはHalogenを使い、ComponentのhandleActionにExtensible Effectsを組み込んでみたいと思います。
PureScriptにおけるExtensible Effectsのライブラリとして、purescript-runを使います。
今後、この記事内では、単にRunと呼ぶこととします。

やってみよう

handleActionでは、何らかの処理を行いStateの更新を行うことになります。
想定としてTodoStateという単純なStateの更新を例にとって考えてみます。

type Todo = { title :: String }

type TodoState = { 
  todos :: Array Todo
}

このStateを更新する一般的な方法は、次のようにMonadStateのmodifyを使うことでしょう。

H.modify_ \s -> s {todos = [{ title: "Todo1" }, { title: "Todo2" }]}

しかし今回はRunを使いたいので、次のようにRun.Stateのmodifyを使います。

displayTodo :: Run (STATE TodoState + ()) Unit
displayTodo = modify \s -> s {todos = [{ title: "Todo1" }, { title: "Todo2" }]}

そして更に実際のアプリケーションでは、上記のような定数値をそのまま使うのではなく、何らかの処理により取得した結果の値を用いてStateを更新するでしょうし、処理が非同期に行われることもよくあるでしょう。
Runで表現するならこんな感じでしょうか。
（非同期での取得処理findTodosは、実際はAffJaxなどを利用して値を取得することになると思います）

findTodos :: Aff (Array Todo)
findTodos = pure [{ title: "Todo1" }, { title: "Todo2" }]

displayTodos :: Run (AFF + STATE TodoState + ()) Unit
displayTodos = do
  todos <- Run.liftAff findTodos
  modify (_{ todos = todos})

displayTodosでは、findTodosで取得した値をRun.liftAffでAFFに持ち上げて、更にSTATEのmodifyを使って状態を更新しています。

この例では説明に必要な最小構成の副作用のみ列挙しています。

さて、上記のdisplayTodoをhandleActionで使うにはどうしたらよいでしょうか。

HalogenMに変換せよ

上記の例のRunを実行して最終的に返す値をHalogenMにします。
これでOK👍です。
なぜならばhandleActionは次のようにHalogenMを期待しているからです。

type EvalSpec state query action slots input output m =
  { handleAction :: action -> HalogenM state action slots output m Unit
  , handleQuery :: forall a. query a -> HalogenM state action slots output m (Maybe a)
  , receive :: input -> Maybe action
  , initialize :: Maybe action
  , finalize :: Maybe action
  }

HalogenMに変換しつつRunを実行するにはこうします。

handleState ::
  forall state action slots output m
  . State state
  ~> H.HalogenM state action slots output m
handleState (State ss sa) = H.HalogenM <<< liftF <<< H.State $ Tuple <$> sa <*> ss

runAffState ::
  forall state action slots output m
  . MonadAff m 
  => Run (STATE state + AFF + ())
  ~> H.HalogenM state action slots output m
runAffState = run $ match { aff: \a -> liftAff a, state: \a -> handleState a }

上記のrunAffStateがRunの実行で、STATEとAFFの2つの副作用を『同時に』除去しています。
非同期処理が含まれないなら次のようにSTATEの除去だけでよいでしょう。

runState ::
  forall state action slots output m
  . Run (STATE state + ())
  ~> H.HalogenM state action slots output m
-- こう書いてもいいが、除去する副作用は1つだけなので、レコード形式で書く必要はないかも
-- runState = run $ match { state: \a -> handleState a }
runState = interpret (on _state handleState case_)

全体像

これまでをまとめた全体像を載せます。

import Prelude

import Control.Monad.Free (liftF)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff, liftAff)
import Halogen as H
import Halogen.HTML as HH
import Run (AFF, Run, match, run)
import Run as Run
import Run.State (STATE, State(..), modify)
import Type.Row (type (+))

type Todo = { title :: String }

type TodoState = { 
  todos :: Array Todo
}

data Action = Initialize

component :: forall q i m. MonadAff m => H.Component q i Void m
component =
  H.mkComponent
    { initialState: \_ -> { todos: [] }
    , render
    , eval: H.mkEval $ H.defaultEval { 
        initialize = Just Initialize,
        handleAction = _handleAction
      }
    }
  where
  render :: forall cs. TodoState -> H.ComponentHTML Action cs m
  render { todos } = 
    HH.div_ [ HH.div_ $ todos <#> \todo -> HH.text todo.title ]
  
  _handleAction :: Action -> H.HalogenM TodoState Action () Void m Unit
  _handleAction = case _ of
    Initialize -> displayTodos # runAffState

displayTodos :: Run (AFF + STATE TodoState + ()) Unit
displayTodos = do
  todos <- Run.liftAff findTodos
  modify (_{ todos = todos})

findTodos :: Aff (Array Todo)
findTodos = pure [{ title: "Todo1" }, { title: "Todo2" }] -- fake implementation

handleState ::
  forall state action slots output m
  . State state
  ~> H.HalogenM state action slots output m
handleState (State ss sa) = H.HalogenM <<< liftF <<< H.State $ Tuple <$> sa <*> ss

runAffState ::
  forall state action slots output m
  . MonadAff m 
  => Run (STATE state + AFF + ())
  ~> H.HalogenM state action slots output m
runAffState = run $ match { aff: \a -> liftAff a, state: \a -> handleState a }

Clean Architectureの例

説明としては以上なのですが、副作用が増えた場合の例として、前回のClean Architectureの例と同じUseCaseをHalogenに合わせて作り変えてみました。

コードの全体はこちらです。
https://github.com/pujoheadsoft/purescript-cleanarchitecture-halogen-run

一部抜粋して見てみると、UseCaseはこんな感じになっています。
以前の例と比較するとSTATE TodoStateの部分が増えています。

Usecases.DisplayCompletedTodos

execute 
  :: UserId
  -> Logics
  -> Run (TODO_PORT + TODO_OUTPUT_PORT + AFF + STATE TodoState + ()) Unit
execute id logics = do
  result <- findTodos id
  case result of
    Right todos -> setTodos $ logics.completed todos
    Left e -> setError e

実行はこんな感じ。

  _handleAction :: Action -> H.HalogenM TodoState Action () Void m Unit
  _handleAction = case _ of
    Initialize -> execute (UserId 1) logics
      # runPort createTodoPort
      # runOutputPort createOutputPort
      # runAffState

テストにおけるUseCaseの実行はこんな感じ。
テスト実行においてはhandleActionのようにHalogenMに変換する必要がないため、Runが用意しているrunStateやrunBaseAffで十分です。

      _ <- execute userId logics
        # runPort todoPort
        # runOutputPort todoOutputPort
        # runState {todos: [], errorMessage: Nothing}
        # runBaseAff
      
      verify stateForTodosMock completedTodos

ちょっと解説

実現方法だけ書いて、なぜ動作するのかを全く説明していなかったので、

run $ match { aff: \a -> liftAff a, state: \a -> handleState a }

の部分をちょっと軽く解説しておこうとおもいます。

これはRun、VariantF、Freeなどにまたがった話で、真面目に解説しだすと分量が増えるので今回は軽くにとどめさせてください。

まずrunAffStateのイータ変換をやめてみます。

runAffState
  :: forall state action slots output m
   . MonadAff m 
  => Run (STATE state + AFF + ())
  ~> H.HalogenM state action slots output m
runAffState r = (run $ match { aff: \a -> liftAff a, state: \a -> handleState a }) r

matchにRecordを渡した結果を更にrunに渡した結果にRunを渡していますね。

そしてmatchの定義はこうです。
これはRecordとVariantFをとる関数になっています。

match
  :: forall rl r r1 r2 a b
   . RL.RowToList r rl
  => VariantFMatchCases rl r1 a b
  => R.Union r1 () r2
  => Record r
  -> VariantF r2 a
  -> b
match r = case_ # onMatch r

PureScriptにおける多相バリアントの実装としてData.Variantというものがあります。
VariantFは、そのVariantのFunctorバージョンみたいなやつです。

-- Variant (fooにIntを紐付ける)
someFoo :: forall v. Variant (foo :: Int | v)
someFoo = inj (Proxy :: Proxy "foo") 42

-- VariantF (fooにMaybeを紐付ける。値はInt。)
someFoo :: forall v. VariantF (foo :: Maybe | v) Int
someFoo = inj (Proxy :: Proxy "foo") (Just 42)

matchの引数で渡しているのは { aff: \a -> liftAff a, state: \a -> handleState a }なので、Recordだけが渡されていることになります。
PureScriptの関数はカリー化されているので、このmatchは(VariantF r2 a -> b)という「関数」を返しています（制約は省略）。

続いてrunの定義はこうなっています。

run
  :: forall m a r
   . Monad m
  => (VariantF r (Run r a) -> m (Run r a))
  -> Run r a
  -> m a
run k = loop
  where
    loop :: Run r a -> m a
    loop = resume (\a -> loop =<< k a) pure

runは(VariantF r (Run r a) -> m (Run r a))という関数とRun r aを受け取るようになっているので、先程のmatchが返す関数(VariantF r2 a -> b)を渡すことができます。

rに実際のレコードを代入するとこうなります。
(VariantF (STATE state + AFF + ()) (Run (STATE state + AFF + ()) a)) -> m (Run (STATE state + AFF + ()) a)

制約としてMonad mを返さなければなりませんが、
{ aff: \a -> liftAff a, state: \a -> handleState a }
が返しているのはどちらもMonadのインスタンスになっているので問題ありません。

handleStateが返すのは、HalogenMでこれはMonadのインスタンスになっていますし、
この場合のliftAffが返すのは、HalogenMになり（自動的に選択される）かつHalogenMはMonadAffのインスタンスなのです。

返されたMonadは、loop =<< k aの部分で再帰呼び出しに使われています(Monadだから逆束縛=<<が使える)。

run k = loop
  where
    loop :: Run r a -> m a
    loop = resume (\a -> loop =<< k a) pure

このループによって、{ aff: \a -> liftAff a, state: \a -> handleState a }のRecordに書かれているすべてのパターンが実行され、かつこれらが返すのはMonadのinstanceなので=<<によって継続処理が繋がることになります。

ちなみにこのレコードのaffやstateに紐付けられている関数が呼び出される順序は、Runの処理の順序と一致します。

今回の場合は、displayTodoを見るとわかりますが、AFFのあとにSTATEの処理が呼ばれているので、\a -> liftAff a のあとに \a -> handleState a が呼ばれることになります。

displayTodos :: Run (AFF + STATE TodoState + ()) Unit
displayTodos = do
  todos <- Run.liftAff findTodos
  modify (_{ todos = todos})

このあたりは、Freeのbindの実装を見ると理解できます（以下のようにRunの正体はFreeのラッパーで、derive instanceで各種のinstanceになっているので、実際呼ばれるのはFreeのbind）。

Run

newtype Run r a = Run (Free (VariantF r) a)

derive instance newtypeRun :: Newtype (Run r a) _
derive newtype instance functorRun :: Functor (Run r)
derive newtype instance applyRun :: Apply (Run r)
derive newtype instance applicativeRun :: Applicative (Run r)
derive newtype instance bindRun :: Bind (Run r)
derive newtype instance monadRun :: Monad (Run r)

Control.Monad.Free

data Free f a = Free (FreeView f Val Val) (CatList (ExpF f))

newtype ExpF f = ExpF (Val -> Free f Val)

data FreeView f a b = Return a | Bind (f b) (b -> Free f a)

data Val

instance freeBind :: Bind (Free f) where
  bind (Free v s) k = Free v (snoc s (ExpF (unsafeCoerceBind k)))
    where
    unsafeCoerceBind :: forall a b. (a -> Free f b) -> Val -> Free f Val
    unsafeCoerceBind = unsafeCoerce

Freeのbindは、後続の処理をCatListに追加した新たなFreeを返すような処理になっています。

CatList は Catenable List の実装で、Catenabe Listはすべての操作をO(1)時間で実現するらしいです。
https://www.slideshare.net/yuganda/pfds-1021-lists-with-efficient-catenation

つまり後続の処理は次々とCatListに蓄積されていくわけです。
この蓄積された処理は、resumeの中で取り出されるようになっています。

後書きのようなもの

実現方法を最初の方にさらっと書きましたが、試みた当初はうまくいかずハマっていました。

例えば最初は、runStateとrunBaseAffでいけるだろ、こうだ。

    Initialize -> displayTodos
      # runState
      # runBaseAff

ってやって・・・・・・コンパイルエラーになるみたいなことを繰り返してました。

なぜならばrunStateの定義はこうなっており、State(今回の例だとTodoState)を渡してやらないといけないからです。

runState :: forall s r a. s -> Run (STATE s + r) a -> Run r (Tuple s a)
runState = runStateAt _state

handleActionにはStateが渡ってくるわけではなく、普通はこんな感じでHalogen(正確にはControl.Monad.State.Class)のmodify_などを使って、渡されてくるStateを更新しますよね。

    Initialize -> H.modify_ \s -> s {todos = []}

ということで、runStateはできない、と。

で、あればですよ。modify_の定義を見てやって、もうその通りの型を返してやればいいのではないかと考えまして。

modify_ :: forall s m. MonadState s m => (s -> s) -> m Unit
modify_ f = state \s -> Tuple unit (f s)

つまり、このようにMonadStateを返すようにしてみたらどうか、と。

displayTodos2 :: forall m. MonadState TodoState m => Run (AFF + ()) (m Unit)
displayTodos2 = do
  todos <- Run.liftAff findTodos
  pure $ modify_ (_{ todos = todos})

んで実行はこう。

  _handleAction :: Action -> H.HalogenM TodoState Action () Void m Unit
  _handleAction = case _ of
    Initialize -> displayTodos2
      # runBaseAff
      # liftAff

runBaseAffが返すのはAffで、_handleActionはHalogenMを期待しているので、liftAffで持ち上げてやっています。HalogenMはMonadAffのinstanceなので持ち上げられるのです。

instance monadAffHalogenM :: MonadAff m => MonadAff (HalogenM state action slots output m) where
  liftAff = HalogenM <<< liftF <<< Lift <<< liftAff

さあ、いけるだろう。

が・・・・・ 駄目っ・・・・・！

型が合わない。これが現実。

  Could not match type

    t2 Unit

  with type

    Unit

何なのだ、これは！どうすればいいのだ？！

という日々を過ごして、やっとこ解決策にたどり着いて、せっかくだからとこの記事を書くことにしたのです。

HalogenでRunを使ってみようという人が果たしてどれくらいいるのか私にはわかりませんが、そんな人のお役に立てれば幸いです。