Home About Contact
Haskell , Monad

Haskell / 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
  ]

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

src/Lib.hs の修正

これらのエラーを含んだ入力データに対応できるように、src/Lib.hs に修正を加えます。

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

エラーの場合に対処できるように Maybe a 型 (Item を Maybe Item に、Price を Maybe Price）に変更しました。

app/Main.hs の修正

アイテム名のリスト

ユニークなアイテム名のリストを作成。これは変更ありません。

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

ItemSet リスト

次に [ItemSet] をつくります。 前回は type ItemSet = (Item, Item) でしたが、これを今回 type ItemSet = (Maybe Item, Maybe Item) に変更しました。 新旧のアイテムリストで対応するアイテムが存在しない場合にも対処できるように [ItemSet] をつくるコードを修正します。

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

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

[(Just Caffe Americano/400,Just Caffe Americano/420)
,(Just Pike Place Roast/450,Just Pike Place Roast/420)
,(Just Caffe Misto/500,Nothing)
,(Nothing,Just Cappuccino/520)]

新旧アイテムリストで片方にしか存在していないアイテム（Caffe Misto と Cappuccino）は、意図通り片方が Nothing になっています。

ItemSet を ItemResult に変換

前回と異なり Maybe を含んでいるので、それに対応するように修正します。

itemResults :: [ItemResult]
itemResults =
  map
    (\itemSet ->
       ItemResult (name itemSet) (maybeOldPrice itemSet) (maybeNowPrice 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)

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

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

Maybe Item から Maybe Name や Maybe Price を取り出すために maybeItemName, maybeitemPrice 関数を定義しています。

Maybe Name から Name を取り出すために maybe defaultName id (maybeItemName (fst itemSet)) している部分のからくりはこちらのエントリーを参照。

ItemResult の Name は (その後に続く Price と異なり） Maybe Name ではなく Name そのものです。 したがって ItemSet から この Name値を解決するために、 ItemSet に含まれる 新旧どちらかの Item で Nothing でない方 から Name値を取得しています。

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

[Caffe Americano/Just 400/Just 420
,Pike Place Roast/Just 450/Just 420
,Caffe Misto/Just 500/Nothing
,Cappuccino/Nothing/Just 520]

まとめ

これでエラーを含んだ入力データの処理に対処できた。しかし、まだ、エラーの内容がログとして書き出されていない。 次のエントリーでは Writer モナドを使ってこの問題を解決する。

ここまでのコードをまとめて掲載します。

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 = (Maybe Item, Maybe Item)

data ItemResult =
  ItemResult Name (Maybe Price) (Maybe 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

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" 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

itemResults :: [ItemResult]
itemResults =
  map
    (\itemSet ->
       ItemResult (name itemSet) (maybeOldPrice itemSet) (maybeNowPrice 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)

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