Haskell / コーヒーメニューの価格改訂リストの作成 エクセルデータからの読み書き対応（書き出し編）

コーヒーメニューの価格改訂リストの作成の後編です。 読み取った新旧のコーヒーメニューリストをコーヒー名をキーにマージして旧価格／新価格を一覧にします。 また、エラーが含まれていたらログも書き出します。

書き出し

新旧価格情報をマージする処理は、後回しにしてまずは、エクセルデータとして書き出すコードを書きます。 エクセルデータとしての書き出しコードはこのエントリーのコードを使います。 これをモジュールに追加しましょう。

src/Lib.hs に以下を追記:

type RowIndex = Int

createXlsx :: Worksheet -> SheetName -> Xlsx
createXlsx sheet sheetName =  def & atSheet sheetName ?~ sheet

addCellValue :: Worksheet -> CellValue -> RowAndCol -> Worksheet
addCellValue sheet cellValue rowAndCol = ((cellValueAt rowAndCol) ?~ cellValue) sheet

addCellValues :: Worksheet -> [CellValue] -> RowIndex -> Worksheet
addCellValues sheet cellValues rowIndex = addCellValues' sheet pairs
  where
    pairs :: [(CellValue, RowAndCol)]
    pairs = (zip cellValues (map (\colIndex -> (rowIndex,colIndex)) $ take (length cellValues) [1..]))
    addCellValues' :: Worksheet -> [(CellValue, RowAndCol)] -> Worksheet
    addCellValues' sheet' xs 
      | (length xs)==0 = sheet'
      | otherwise      = addCellValues' newSheet (tail xs)
        where newSheet = addCellValue sheet' (fst $ head xs) (snd $ head xs)

そして、追加した関数 addCellValues, createXlsx, RowIndex を忘れずにエクスポートしておきます。

app/Main.hs を以下のようにします。

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Codec.Xlsx (toXlsx,fromXlsx, CellValue(CellText, CellDouble), def, Worksheet)
import Control.Monad (forM)
import qualified Data.ByteString.Lazy as L
import Data.Time.Clock.POSIX
import Lib

addBodyRows :: Worksheet -> [BodyRow] -> RowIndex -> Worksheet
addBodyRows sheet bodyRows rowIndex
  | (length bodyRows)==0 = sheet
  | otherwise = addBodyRows sheet' (tail bodyRows) (rowIndex+1)
  where
    sheet' = addCellValues sheet [cellValueName, cellValuePrice] rowIndex
    bodyRow = head bodyRows
    maybeCellValueName = toCellValue nameKey bodyRow
    maybeCellValuePrice = toCellValue priceKey bodyRow
    cellValueName = maybe (CellText "") id maybeCellValueName
    cellValuePrice = maybe (CellDouble 0) id maybeCellValuePrice

main :: IO ()
main = do
  bs <- L.readFile "Input/oldItems.xlsx"
  ct <- getPOSIXTime
  let sheetName = "Sheet1"
      xlsx = toXlsx bs
      bodyRows = toBodyRows xlsx sheetName

      newSheet1 = addCellValues def [(CellText "name"),(CellText "price")] 1
      newSheet2 = addBodyRows newSheet1 bodyRows 2
      exportXlsx = createXlsx newSheet2 sheetName
  L.writeFile "exportedOldItems.xlsx" $ fromXlsx ct exportXlsx

Data.Time.Clock.POSIX をインポートしたので、package.yml の dependencies に time を追加する必要があります。

addBodyRows 関数でoldItems.xlsx から取得したbody の複数行（bodyRows）をスプレッドシートに再帰的に追加しています。

書き出された exportedOldItems.xlsx:

新旧価格をマージしたアイテムリストをつくる

src/Lib.hs

新旧の価格つきコーヒーメニューアイテム情報を処理するために次のような型を追加します。

type Name = CellValue
type Price = CellValue

data Item = Item Name Price deriving Show
data MergedItem = MergedItem Name Price Price deriving Show

[BodyRow] を [Item] へ変換する関数を追加します。

toItems :: [BodyRow] -> [Item]
toItems bodyRows = map (\bodyRow -> toItem bodyRow) bodyRows
  where
    toItem :: BodyRow -> Item
    toItem bodyRow = Item (cellValueName bodyRow) (cellValuePrice bodyRow)
    cellValueName bodyRow = maybe (CellText "") id (maybeCellValueName bodyRow)
    cellValuePrice bodyRow = maybe (CellDouble 0) id (maybeCellValuePrice bodyRow)
    maybeCellValueName = toCellValue nameKey
    maybeCellValuePrice = toCellValue priceKey

補助関数 itemName, itemPrice を追加:

itemName :: Item -> Name
itemName (Item n _) = n

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

最後に Libモジュールから Name, Price, Item(Item), MergedItem(MergedItem), ItemSet, toItems, itemName, itemPrice をエクスポートしておきます。

src/Lib.hs へのコード追加は以上です。

app/Main.hs

app/Main.hs を修正します。

toItemSets は新旧の [BodyRow] から [ItemSet] をつくります。

toItemSets :: [BodyRow] -> [BodyRow] -> [ItemSet]
toItemSets oldBodyRows newBodyRows = do
  oldItem <- toItems oldBodyRows
  nowItem <- toItems newBodyRows
  guard (itemName oldItem == itemName nowItem)
  return (oldItem, nowItem)

toMergedItems は [ItemSet] から [MergedItem] をつくります。

toMergedItems :: [ItemSet] -> [MergedItem]
toMergedItems itemSets =
  map
    (\itemSet ->
       MergedItem
         (itemName (fst itemSet))
         (itemPrice (fst itemSet))
         (itemPrice (snd itemSet)))
    itemSets

先に作成した addBodyRows 関数を修正して addMergedItems にします。 基本的には処理対象を [BodyRow] から [MergedItem] に変更しただけです。

addMergedItems :: Worksheet -> [MergedItem] -> RowIndex -> Worksheet
addMergedItems sheet mergedItems rowIndex
  | (length mergedItems) == 0 = sheet
  | otherwise = addMergedItems sheet' (tail mergedItems) (rowIndex + 1)
  where
    sheet' =
      addCellValues
        sheet
        [(name mergedItem), (oldPrice mergedItem), (newPrice mergedItem)]
        rowIndex
    mergedItem = head mergedItems
    name :: MergedItem -> CellValue
    name (MergedItem v _ _) = v
    oldPrice :: MergedItem -> CellValue
    oldPrice (MergedItem _ v _) = v
    newPrice :: MergedItem -> CellValue
    newPrice (MergedItem _ _ v) = v

以上の関数を駆使して、エクセル書き出しを行うコード:

main :: IO ()
main = do
  oldBs <- L.readFile "Input/oldItems.xlsx"
  newBs <- L.readFile "Input/newItems.xlsx"
  ct <- getPOSIXTime
  let sheetName = "Sheet1"
      oldXlsx = toXlsx oldBs
      oldBodyRows = toBodyRows oldXlsx sheetName
      newXlsx = toXlsx newBs
      newBodyRows = toBodyRows newXlsx sheetName
      itemSets = toItemSets oldBodyRows newBodyRows
      mergedItems = toMergedItems itemSets
      newSheet1 =
        addCellValues
          def
          [(CellText "name"), (CellText "oldPrice"), (CellText "newPrice")]
          1
      newSheet2 = addMergedItems newSheet1 mergedItems 2
      exportXlsx = createXlsx newSheet2 sheetName
  L.writeFile "exportedMergedItems.xlsx" $ fromXlsx ct exportXlsx

実行結果:

newItems.xlsx にしか存在しない Cappuccino は出力されません。 これを出力できるようにするには、このエントリーでやったように、欠損している情報に対処する必要があります。

コードが長くなりすぎるので、欠損への対処コードは割愛します。

まとめ

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

src/Lib.hs :

{-# LANGUAGE OverloadedStrings #-}

module Lib
  ( Key
  , BodyRow
  , toRowCount
  , toCellValue
  , toBodyRows
  , nameKey
  , priceKey
  , RowIndex
  , addCellValues
  , createXlsx
  , Name
  , Price
  , Item(Item)
  , MergedItem(MergedItem)
  , ItemSet
  , toItems
  , itemName
  , itemPrice
  ) where

import Codec.Xlsx
import Control.Lens
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import qualified Data.Text as T


type SheetName = T.Text
type RowAndCol = (Int, Int)

toMaybeCellValue :: Xlsx -> SheetName -> RowAndCol -> Maybe CellValue
toMaybeCellValue xlsx sheetName rowAndCol =
  xlsx ^? ixSheet sheetName . ixCell rowAndCol . cellValue . _Just

toColCount' :: Xlsx -> SheetName -> Int -> Int
toColCount' xlsx sheetName colIndex
  | isNothing = colIndex - 1
  | otherwise = toColCount' xlsx sheetName (colIndex + 1)
  where
    isNothing =
      if (toMaybeCellValue xlsx sheetName (1, colIndex)) == Nothing
        then True
        else False

toColCount :: Xlsx -> SheetName -> Int
toColCount xlsx sheetName = toColCount' xlsx sheetName 1

toRowCount' :: Xlsx -> SheetName -> Int -> Int
toRowCount' xlsx sheetName rowIndex
  | isNothing = rowIndex - 1
  | otherwise = toRowCount' xlsx sheetName (rowIndex + 1)
  where
    isNothing =
      if (toMaybeCellValue xlsx sheetName (rowIndex, 1)) == Nothing
        then True
        else False

toRowCount :: Xlsx -> SheetName -> Int
toRowCount xlsx sheetName = toRowCount' xlsx sheetName 1

type BodyRowIndex = Int

data Key =
  Key CellValue
  deriving (Show, Eq, Ord)

data BodyRow =
  BodyRow (Map.Map Key (Maybe CellValue))
  deriving (Show)

toKeys :: Xlsx -> SheetName -> [Key]
toKeys xlsx sheetName = map (\cv -> Key cv) (toHeaders xlsx sheetName)

toHeaders :: Xlsx -> SheetName -> [CellValue]
toHeaders xlsx sheetName =
  map (\mcv -> maybe (CellText "unknown") id mcv) (toHeaders' xlsx sheetName)

toHeaders' :: Xlsx -> SheetName -> [Maybe CellValue]
toHeaders' xlsx sheetName =
  map
    (\colIndex -> toMaybeCellValue xlsx sheetName (1, colIndex))
    (take colCount [1 ..])
  where
    colCount = toColCount xlsx sheetName

toBodyRow :: Xlsx -> SheetName -> BodyRowIndex -> BodyRow
toBodyRow xlsx sheetName bodyRowIndex =
  BodyRow (Map.fromList $ zip keys maybeCellValues)
  where
    colCount = toColCount xlsx sheetName
    keys = toKeys xlsx sheetName
    maybeCellValues =
      map
        (\colIndex ->
           toMaybeCellValue xlsx sheetName ((bodyRowIndex + 1), colIndex))
        (take colCount [1 ..])

toBodyRows :: Xlsx -> SheetName -> [BodyRow]
toBodyRows xlsx sheetName =
  map
    (\bodyRowIndex -> toBodyRow xlsx sheetName bodyRowIndex)
    (take (rowCount - 1) [1 ..])
  where
    rowCount = toRowCount xlsx sheetName

toCellValue :: Key -> BodyRow -> Maybe CellValue
toCellValue key bodyRow = maybe Nothing id maybeMaybeCellValue
  where
    maybeMaybeCellValue = Map.lookup key bodyRowMap
    bodyRowMap = toBodyRowMap bodyRow
    toBodyRowMap (BodyRow v) = v

nameKey :: Key
nameKey = Key (CellText "name")

priceKey :: Key
priceKey = Key (CellText "price")


type RowIndex = Int

createXlsx :: Worksheet -> SheetName -> Xlsx
createXlsx sheet sheetName =  def & atSheet sheetName ?~ sheet

addCellValue :: Worksheet -> CellValue -> RowAndCol -> Worksheet
addCellValue sheet cellValue rowAndCol = ((cellValueAt rowAndCol) ?~ cellValue) sheet

addCellValues :: Worksheet -> [CellValue] -> RowIndex -> Worksheet
addCellValues sheet cellValues rowIndex = addCellValues' sheet pairs
  where
    pairs :: [(CellValue, RowAndCol)]
    pairs = (zip cellValues (map (\colIndex -> (rowIndex,colIndex)) $ take (length cellValues) [1..]))
    addCellValues' :: Worksheet -> [(CellValue, RowAndCol)] -> Worksheet
    addCellValues' sheet' xs 
      | (length xs)==0 = sheet'
      | otherwise      = addCellValues' newSheet (tail xs)
        where newSheet = addCellValue sheet' (fst $ head xs) (snd $ head xs)


type Name = CellValue
type Price = CellValue

data Item = Item Name Price deriving Show
data MergedItem = MergedItem Name Price Price deriving Show

type ItemSet = (Item, Item)

toItems :: [BodyRow] -> [Item]
toItems bodyRows = map (\bodyRow -> toItem bodyRow) bodyRows
  where
    toItem :: BodyRow -> Item
    toItem bodyRow = Item (cellValueName bodyRow) (cellValuePrice bodyRow)
    cellValueName bodyRow = maybe (CellText "") id (maybeCellValueName bodyRow)
    cellValuePrice bodyRow = maybe (CellDouble 0) id (maybeCellValuePrice bodyRow)
    maybeCellValueName = toCellValue nameKey
    maybeCellValuePrice = toCellValue priceKey

itemName :: Item -> Name
itemName (Item n _) = n

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

app/Main.hs :

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Codec.Xlsx
  ( CellValue(CellDouble, CellText)
  , Worksheet
  , def
  , fromXlsx
  , toXlsx
  )
import Control.Monad (forM, guard)
import qualified Data.ByteString.Lazy as L
import Data.Time.Clock.POSIX
import Lib

toItemSets :: [BodyRow] -> [BodyRow] -> [ItemSet]
toItemSets oldBodyRows newBodyRows = do
  oldItem <- toItems oldBodyRows
  nowItem <- toItems newBodyRows
  guard (itemName oldItem == itemName nowItem)
  return (oldItem, nowItem)

toMergedItems :: [ItemSet] -> [MergedItem]
toMergedItems itemSets =
  map
    (\itemSet ->
       MergedItem
         (itemName (fst itemSet))
         (itemPrice (fst itemSet))
         (itemPrice (snd itemSet)))
    itemSets

addMergedItems :: Worksheet -> [MergedItem] -> RowIndex -> Worksheet
addMergedItems sheet mergedItems rowIndex
  | (length mergedItems) == 0 = sheet
  | otherwise = addMergedItems sheet' (tail mergedItems) (rowIndex + 1)
  where
    sheet' =
      addCellValues
        sheet
        [(name mergedItem), (oldPrice mergedItem), (newPrice mergedItem)]
        rowIndex
    mergedItem = head mergedItems
    name :: MergedItem -> CellValue
    name (MergedItem v _ _) = v
    oldPrice :: MergedItem -> CellValue
    oldPrice (MergedItem _ v _) = v
    newPrice :: MergedItem -> CellValue
    newPrice (MergedItem _ _ v) = v

main :: IO ()
main = do
  oldBs <- L.readFile "Input/oldItems.xlsx"
  newBs <- L.readFile "Input/newItems.xlsx"
  ct <- getPOSIXTime
  let sheetName = "Sheet1"
      oldXlsx = toXlsx oldBs
      oldBodyRows = toBodyRows oldXlsx sheetName
      newXlsx = toXlsx newBs
      newBodyRows = toBodyRows newXlsx sheetName
      itemSets = toItemSets oldBodyRows newBodyRows
      mergedItems = toMergedItems itemSets
      newSheet1 =
        addCellValues
          def
          [(CellText "name"), (CellText "oldPrice"), (CellText "newPrice")]
          1
      newSheet2 = addMergedItems newSheet1 mergedItems 2
      exportXlsx = createXlsx newSheet2 sheetName
  L.writeFile "exportedMergedItems.xlsx" $ fromXlsx ct exportXlsx