Saturday, March 26, 2022

Haskell / Writer モナドを使ったコーヒーメニューの価格改訂リストの作成

Writer モナドの使用例としてその１ / その２ / その３とエントリーを書いたのだが、気に入らない。結局 Writer モナドを使う必要のないコードになってしまった。

今回はその１〜３のコードをリファクタリングして、Writer モナドを使うべき理由のあるコードに直します。

処理する入力データは前回のものをそのまま使います。

oldItems :: [Item]
oldItems =
  [ Item "Caffe Americano" 400
  , Item "Pike Place Roast" 450
  , Item "Caffe Misto" 500
  ]

nowItems :: [Item]
nowItems =
  [ Item "Caffe Americano" 420
  , Item "Pike Place Roast" 420
  , Item "Cappuccino" 520
  ]

このデータは、以下の３つのエラーがあります。

アイテム Caffe Misto が価格改訂後のリスト(nowItems)に含まれていない
アイテム Cappuccino が価格改訂前のリスト(oldItems)に含まれていない
Pike Place Roast の価格が値下げになっていること（値下げで正しい可能性もあるがここではエラーの可能性ありと考えることにします）

これらを処理中に検査してエラーログを付加して処理を継続するようにコードします。

プロジェクトの準備

$ stack new coffee-price
$ cd coffee-price

package.yml の dependencies に mtl を追加:

dependencies:
- base >= 4.7 && < 5
- mtl

src/Lib.hs

前回とほとんど同じです。ただし、ItemResult に Log を入れるのをやめました。

module Lib
  ( Name
  , Price
  , Item(Item)
  , ItemSet
  , ItemResult(ItemResult)
  , itemName
  , itemPrice
  ) where

type Name = String
type Price = Int

data Item = Item Name Price deriving Eq
type ItemSet = (Maybe Item, Maybe Item)
data ItemResult = ItemResult Name (Maybe Price) (Maybe Price)

itemName :: Item -> String
itemName (Item v _) = v

itemPrice :: Item -> Price
itemPrice (Item _ v) = v

instance Show Item where
  show it = foldl1 (\a b -> a ++ "/" ++ b) [(name it), (show $ price it)]
    where
      name = itemName
      price = itemPrice

instance Show ItemResult where
  show it =
    foldl1
      (\a b -> a ++ "/" ++ b)
      [(name it), (show $ oldPrice it), (show $ nowPrice it)]
    where
      name (ItemResult v _ _) = v
      oldPrice (ItemResult _ v _) = v
      nowPrice (ItemResult _ _ v) = v

app/Main.hs

このようなインタフェース（型シグネチャ）にしました。

-- ユニークなコーヒー名のリスト
itemNames :: [Name]

-- コーヒー名から ItemSet を生成
toItemSet :: Name -> Writer [String] ItemSet

-- ItemSet から ItemResult を生成
toItemResult :: ItemSet -> Writer [String] ItemResult

これらの関数を組み合わせて、 Name から ItemSet をつくり、 ItemSet から ItemResult をつくります。その過程でエラーに遭遇したら、 [String] に書き出していく、という考え方です。

results :: [Writer [String] ItemResult]
results = map (\name -> toItemSet name >>= toItemResult) itemNames

最後に ItemResult とそれを生成する過程で生じたエラーログ (String) をタプルにして成果物とします。

results' :: [(ItemResult, String)]
results' =
  map
    (\result -> (fst $ runWriter result, toLog (snd $ runWriter result)))
    results
  where
    toLog :: [String] -> String

実行すると results' は以下の内容になります。

[ (Caffe Americano / Just 400 / Just 420, "")
, (Pike Place Roast / Just 450 / Just 420, "price down")
, (Caffe Misto / Just 500 / Nothing, "now item missing")
, (Cappuccino / Nothing / Just 520, "old item missing")
]

完成したコード app/Main.hs

module Main where

import Control.Monad.Writer
import Data.List
import Lib

oldItems :: [Item]
oldItems =
  [ Item "Caffe Americano" 400
  , Item "Pike Place Roast" 450
  , Item "Caffe Misto" 500
  ]

nowItems :: [Item]
nowItems =
  [ Item "Caffe Americano" 420
  , Item "Pike Place Roast" 420
  , Item "Cappuccino" 520
  ]

itemNames :: [Name]
itemNames = nub $ map (\item -> itemName item) (oldItems ++ nowItems)

toItemSet :: Name -> Writer [String] ItemSet
toItemSet name = writer (itemSet, logOldItem ++ logNowItem)
  where
    itemSet = (maybeOldItem, maybeNowItem)

    logOldItem :: [String]
    logOldItem
      | maybeOldItem == Nothing = ["old item missing"]
      | otherwise = []

    logNowItem :: [String]
    logNowItem
      | maybeNowItem == Nothing = ["now item missing"]
      | otherwise = []

    maybeOldItem :: Maybe Item
    maybeOldItem
      | (length targetOldItems) == 0 = Nothing
      | otherwise = Just $ head targetOldItems

    maybeNowItem :: Maybe Item
    maybeNowItem
      | (length targetNowItems) == 0 = Nothing
      | otherwise = Just $ head targetNowItems

    targetOldItems = targetItems oldItems
    targetNowItems = targetItems nowItems
    targetItems items = filter (\item -> (itemName item) == name) items

toItemResult :: ItemSet -> Writer [String] ItemResult
toItemResult itemSet = writer (itemResult, logs isPriceDown)
  where
    itemResult = ItemResult name maybeOldPrice maybeNowPrice
    defaultName = ""
    name :: String
    name
      | (maybeItemName (fst itemSet)) == Nothing =
        maybe defaultName id (maybeItemName (snd itemSet))
      | otherwise = maybe defaultName id (maybeItemName (fst itemSet))
    maybeOldPrice = maybeItemPrice (fst itemSet)
    maybeNowPrice = maybeItemPrice (snd itemSet)
    logs :: Maybe Bool -> [String]
    logs Nothing = []
    logs (Just priceDown)
      | priceDown = ["price down"]
      | otherwise = []
    isPriceDown :: Maybe Bool
    isPriceDown = do
      oldPrice <- maybeOldPrice
      nowPrice <- maybeNowPrice
      Just (oldPrice > nowPrice)

maybeItemName :: Maybe Item -> Maybe Name
maybeItemName Nothing = Nothing
maybeItemName (Just item) = Just $ itemName item

maybeItemPrice :: Maybe Item -> Maybe Price
maybeItemPrice Nothing = Nothing
maybeItemPrice (Just item) = Just $ itemPrice item


results :: [Writer [String] ItemResult]
results = map (\name -> toItemSet name >>= toItemResult) itemNames

results' :: [(ItemResult, String)]
results' =
  map
    (\result -> (fst $ runWriter result, toLog (snd $ runWriter result)))
    results
  where
    toLog :: [String] -> String
    toLog [] = ""
    toLog ss = foldl1 (\a b -> a ++ "," ++ b) ss


main :: IO ()
main = putStrLn $ show results'

Name から ItemSet を作り出すときに、対応アイテムがない場合は old / now item missing エラーをログを書き出す、 ItemSet から ItemResult を作り出すときに、価格を調べて必要なら price down エラーを書き出すようにしました。