Haskell / 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 の価格が値下げになっていること（値下げで正しい可能性もあるがここではエラーの可能性ありと考えることにします）

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

src/Lib.hs の修正

最終的なデータとなる ItemResult にログを記録できるように src/Lib.hs を修正します。

type Log = String
--data ItemResult = ItemResult Name (Maybe Price) (Maybe Price)
data ItemResult = ItemResult Name (Maybe Price) (Maybe Price) (Maybe Log)

instance Show ItemResult ... も修正する必要があります。

また Item を比較する機能をあとで追加予定なので deriving Eq しておきます。

data Item = Item Name Price deriving Eq

src/Lib.sh の修正は以上です。

app/Main.hs の修正

Writer モナドを使うので import します。

import Control.Monad.Writer

これを使うには、mtl が必要なので、それを package.yml の dependencies へ追記。

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

入力データに含まれるエラーを検査するために itemSetChecker という type を定義します。

type ItemSetChecker = ItemSet -> Writer [Maybe String] ItemSet

この型シノニムを持った関数をエラーの種類ごとに用意していきます。

対応する古いアイテムがない、というエラーのチェック:

oldItemNothingChecker :: ItemSetChecker
oldItemNothingChecker itemSet
  | maybeOldItem == Nothing = writer (itemSet, [Just "old item missing"])
  | otherwise = writer (itemSet, [Nothing])
  where
    maybeOldItem :: Maybe Item
    maybeOldItem = fst itemSet

対応する新しいアイテムがない、というエラーのチェック:

nowItemNothingChecker :: ItemSetChecker
nowItemNothingChecker itemSet
  | maybeNowItem == Nothing = writer (itemSet, [Just "now item missing"])
  | otherwise = writer (itemSet, [Nothing])
  where
    maybeNowItem :: Maybe Item
    maybeNowItem = snd itemSet

価格が安くなっているかどうのチェック:

priceDownChecker :: ItemSetChecker
priceDownChecker itemSet
  | oldPrice > nowPrice = writer (itemSet, [Just "price down"])
  | otherwise = writer (itemSet, [Nothing])
  where
    oldPrice :: Price
    oldPrice = maybe 0 id $ maybeItemPrice (fst itemSet)
    nowPrice :: Price
    nowPrice = maybe 0 id $ maybeItemPrice (snd itemSet)

以上の ItemSet チェックを一つの関数にまとめた:

applyAllItemSetCheckers :: ItemSetChecker
applyAllItemSetCheckers itemSet =
  (return itemSet)
  >>= oldItemNothingChecker
  >>= nowItemNothingChecker
  >>= priceDownChecker

最後に itemResults を計算します。

itemResults :: [ItemResult]
itemResults =
  map
    (\itemSet ->
       ItemResult
         (name itemSet)
         (maybeOldPrice itemSet)
         (maybeNowPrice itemSet)
         (toLog itemSet))
    itemSets
  where
    defaultName = ""
    name :: ItemSet -> String
    name itemSet
      | (maybeItemName (fst itemSet)) == Nothing =
        maybe defaultName id (maybeItemName (snd itemSet))
      | otherwise = maybe defaultName id (maybeItemName (fst itemSet))
    maybeOldPrice itemSet = maybeItemPrice (fst itemSet)
    maybeNowPrice itemSet = maybeItemPrice (snd itemSet)
    toLog :: ItemSet -> Maybe String
    toLog itemSet
      | (length $ toLogs itemSet) == 0 = Nothing
      | otherwise =
        Just $
        foldl1
          (\a b -> a ++ "," ++ b)
          (map (\maybeString -> (maybe "" id maybeString)) (toLogs itemSet))
    toLogs :: ItemSet -> [Maybe String]
    toLogs itemSet = filter (\log -> log /= Nothing) $ toLogs' itemSet
    toLogs' :: ItemSet -> [Maybe String]
    toLogs' itemSet = snd $ runWriter (checkResult itemSet)
    checkResult :: ItemSet -> Writer [Maybe String] ItemSet
    checkResult itemSet = applyAllItemSetCheckers itemSet

結果として、 ItemResults の内容はこれになりました。

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

エラーのある ItemResult にエラーログが付加されています。

Caffe Misto は新しいアイテムが Nothing になっているのに エラーログに price down と出ています。これは Maybe Price のデフォルト値を 0 として計算しているためです。これも対処可能ですが、今はこれでよいこととします。

まとめ

結局、ItemSet のチェックコードを Writer モナドで継続してエラーを探す（ログを書き出す）処理をしているのですが(applyAllItemSetCheckers)、 その結果の ItemSet は使用していません。 それは、そこでエラーを調べているだけで、ItemSet の内容を変更していないからです。

だったら、 Writer モナドを使う意味なくない ？

Writer モナドを使う意味のあるコードにリファクタリングしました。 Writer モナドを使ったコーヒーメニューの価格改訂リストの作成

それならば、 type CheckError = ItemSet -> Maybe String のような型シノニムで（Writer モナドなどをわざわざ使わなくても）解決できるはず。 そのあたりがとても気に入らないサンプルコードになりましたが、とりあえず今はこれで完成とします。

最後に完成したコードをメモしておきます。

src/Lib.hs

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

type Name = String
type Price = Int
type Log = String

data Item =
  Item Name Price deriving Eq

type ItemSet = (Maybe Item, Maybe Item)

data ItemResult =
  ItemResult Name (Maybe Price) (Maybe Price) (Maybe Log)

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

itemPrice :: Item -> Int
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), (show $ log it)]
    where
      name (ItemResult v _ _ _) = v
      oldPrice (ItemResult _ v _ _) = v
      nowPrice (ItemResult _ _ v _) = v
      log (ItemResult _ _ _ v) = v

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)

itemSets :: [ItemSet]
itemSets = zip oldItems' nowItems'
  where
    oldItems' = map (\name -> findMaybeItemByItemName name oldItems) itemNames
    nowItems' = map (\name -> findMaybeItemByItemName name nowItems) itemNames
    findMaybeItemByItemName :: Name -> [Item] -> Maybe Item
    findMaybeItemByItemName name items
      | length targetItems == 0 = Nothing
      | otherwise = Just $ head targetItems
      where
        targetItems = filter (\item -> (itemName item) == name) items

type ItemSetChecker = ItemSet -> Writer [Maybe String] ItemSet

oldItemNothingChecker :: ItemSetChecker
oldItemNothingChecker itemSet
  | maybeOldItem == Nothing = writer (itemSet, [Just "old item missing"])
  | otherwise = writer (itemSet, [Nothing])
  where
    maybeOldItem :: Maybe Item
    maybeOldItem = fst itemSet

nowItemNothingChecker :: ItemSetChecker
nowItemNothingChecker itemSet
  | maybeNowItem == Nothing = writer (itemSet, [Just "now item missing"])
  | otherwise = writer (itemSet, [Nothing])
  where
    maybeNowItem :: Maybe Item
    maybeNowItem = snd itemSet

priceDownChecker :: ItemSetChecker
priceDownChecker itemSet
  | oldPrice > nowPrice = writer (itemSet, [Just "price down"])
  | otherwise = writer (itemSet, [Nothing])
  where
    oldPrice :: Price
    oldPrice = maybe 0 id $ maybeItemPrice (fst itemSet)
    nowPrice :: Price
    nowPrice = maybe 0 id $ maybeItemPrice (snd itemSet)

applyAllItemSetCheckers :: ItemSetChecker
applyAllItemSetCheckers itemSet =
  (return itemSet) >>= oldItemNothingChecker >>= nowItemNothingChecker >>=
  priceDownChecker

itemResults :: [ItemResult]
itemResults =
  map
    (\itemSet ->
       ItemResult
         (name itemSet)
         (maybeOldPrice itemSet)
         (maybeNowPrice itemSet)
         (toLog itemSet))
    itemSets
  where
    defaultName = ""
    name :: ItemSet -> String
    name itemSet
      | (maybeItemName (fst itemSet)) == Nothing =
        maybe defaultName id (maybeItemName (snd itemSet))
      | otherwise = maybe defaultName id (maybeItemName (fst itemSet))
    maybeOldPrice itemSet = maybeItemPrice (fst itemSet)
    maybeNowPrice itemSet = maybeItemPrice (snd itemSet)
    toLog :: ItemSet -> Maybe String
    toLog itemSet
      | (length $ toLogs itemSet) == 0 = Nothing
      | otherwise =
        Just $
        foldl1
          (\a b -> a ++ "," ++ b)
          (map (\maybeString -> (maybe "" id maybeString)) (toLogs itemSet))
    toLogs :: ItemSet -> [Maybe String]
    toLogs itemSet = filter (\log -> log /= Nothing) $ toLogs' itemSet
    toLogs' :: ItemSet -> [Maybe String]
    toLogs' itemSet = snd $ runWriter (checkResult itemSet)
    checkResult :: ItemSet -> Writer [Maybe String] ItemSet
    checkResult itemSet = applyAllItemSetCheckers itemSet

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

main :: IO ()
main = putStrLn $ show itemResults