Haskell / Writer モナドを使ったより実践的なコード（その１）

Writer についてこのエントリーで軽く使い方を調べました。今回はコーヒーの価格改訂を題材にして Writer モナドを使ってみます。

ここでは次のようなケースについて考えてみます。

以下の３つのコーヒーメニューアイテムがあるとします。

Caffe Americano / 400yen
Pike Place Roast / 450yen
Caffe Misto / 500yen

これらが事情により値上げとなり、以下のようになったとします。

Caffe Americano / 420yen
Pike Place Roast / 480yen
Caffe Misto / 580yen

そこで改訂前と後の価格がアイテムごとに把握できるデータを作成します。

Caffe Americano / 400yen / 420yen
Pike Place Roast / 450yen / 480yen
Caffe Misto / 500yen / 580yen

方針として、まずはデータにエラーが含まれていないケースについて考えます（その１）。その後データにエラー（不備等）があった場合に対処できるコードを Writer モナドを使って書くことにします（その２）。

その１）データに不備がない場合

はじめに stack new してプロジェクトを作成します。

$ stack new coffee-price
$ cd coffee-price

src/Lib.hs にこのコーヒーメニューをモデル化するためのコードを用意します。

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

type Name = String
type Price = Int

data Item = Item Name Price
type ItemSet = (Item, Item)
data ItemResult = ItemResult Name Price Price

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)]
    where
      name (ItemResult v _ _) = v
      oldPrice (ItemResult _ v _) = v
      nowPrice (ItemResult _ _ v) = v

app/Main.hs は以下のように Item を使って古いアイテムリスト(oldItems)と新しいアイテムリスト(nowItems)を作成します。

module Main where

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" 480
  , Item "Caffe Misto" 580
  ]

main :: IO ()
main = putStrLn $ show (oldItems ++ nowItems)

作動を確かめます。

$ stack run
[Caffe Americano/400
,Pike Place Roast/450
,Caffe Misto/500
,Caffe Americano/420
,Pike Place Roast/480
,Caffe Misto/580]

新旧両方のアイテムが全部出力されました、意図通りです。

それでは、アイテム名(Name)をキーにして、同じアイテム名で古いアイテムと新しいアイテムをセットにした ItemSet をつくります。

最初にアイテム名を全部収集してユニークなアイテム名だけのリストをつくります。

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

nub はリスト内から重複を取り除く関数です。

これで itemNames の内容は次のようになります。

["Caffe Americano","Pike Place Roast","Caffe Misto"]

次に、同じアイテム名を持つアイテムを新旧のリストから見つけて ItemSets をつくります。

itemSets :: [ItemSet]
itemSets = zip oldItems' nowItems'
  where
    oldItems' = map (\name -> findItemByItemName name oldItems) itemNames
    nowItems' = map (\name -> findItemByItemName name nowItems) itemNames

    findItemByItemName :: Name -> [Item] -> Item
    findItemByItemName name items = head $ filter (\item -> (itemName item)==name) items

補助関数として findItemByItemName を用意しました。アイテム名からアイテムを引くための関数です。

今のところ、見つけた（複数の）アイテムのうち先頭だけを取り出しています。もし、該当するアイテムがみつからなければ、エラーになりますが、現段階ではデータにエラーは含まれていないことを前提としているので、これで良いこととします。（その２で対処方法を考えます。）

itemSets の内容は以下のようになります。

[(Caffe Americano/400,Caffe Americano/420)
,(Pike Place Roast/450,Pike Place Roast/480)
,(Caffe Misto/500,Caffe Misto/580)]

最後に、ItemSet を ItemResult に変換するだけです。

itemResults :: [ItemResult]
itemResults =
  map
    (\itemSet -> ItemResult (name itemSet) (oldPrice itemSet) (nowPrice itemSet))
    itemSets
  where
    name itemSet = itemName (fst itemSet)
    oldPrice itemSet = itemPrice (fst itemSet)
    nowPrice itemSet = itemPrice (snd itemSet)

itemResults の内容は以下のようになります。

$ stack run
[Caffe Americano/400/420
,Pike Place Roast/450/480
,Caffe Misto/500/580]

新旧のコーヒーメニューアイテム(Item)のリストから、価格改訂情報を含んだアイテム(ItemResult)リストが作成できました。

その１）まとめ

以上でデータにエラーが含まれない場合のコードが完成しました。

app/Main.hs 全体のコードです。

module Main where

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" 480
  , Item "Caffe Misto" 580
  ]

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

itemSets :: [ItemSet]
itemSets = zip oldItems' nowItems'
  where
    oldItems' = map (\name -> findItemByItemName name oldItems) itemNames
    nowItems' = map (\name -> findItemByItemName name nowItems) itemNames
    findItemByItemName :: Name -> [Item] -> Item
    findItemByItemName name items =
      head $ filter (\item -> (itemName item) == name) items

itemResults :: [ItemResult]
itemResults =
  map
    (\itemSet -> ItemResult (name itemSet) (oldPrice itemSet) (nowPrice itemSet))
    itemSets
  where
    name itemSet = itemName (fst itemSet)
    oldPrice itemSet = itemPrice (fst itemSet)
    nowPrice itemSet = itemPrice (snd itemSet)

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

処理するデータにエラーが含まれる場合その２へ続きます。

Haskell / Writer モナドを使ったより実践的なコード（その１）

その１）データに不備がない場合

その１） まとめ

その１）まとめ