カレンダー整形問題をHaskellで、それも日本語で読めるように書いてみた

カレンダー整形問題Haskellの回答に、日本語による解説をコメントとしてではなく動作する関数として加えてみた。個人的に気に入っているのは「を」関数。
なおgistに投稿済み。

module Main where

import Data.List.Split
import Data.Time.Calendar
import Data.Time.Calendar.WeekDate
import Data.Time.Clock
import Data.Time.Format
import Data.Time.LocalTime
import Data.Text (pack, unpack, center)
import System.Locale

主処理 = main
main = 現在日付を取得 >>= 指定日付を表示用に加工 >>= プリントアウト

現在日付を取得 = getZonedTime
プリントアウト = putStrLn

指定日付を表示用に加工 :: ZonedTime -> IO String
指定日付を表示用に加工 任意の日付 = do
  日付               <- 任意の日付 `を` 扱いやすい型に変換                           -- ZonedTime -> Day
  日付リスト         <- 日付 `を` 週毎の日付に分割して先頭週の開始曜日までは空文字を詰めたリストに変換 -- Day -> [[String]]
  日付行リスト       <- 日付リスト `を` 行毎の文字列に連結したリストに変換           -- [[String]] -> [String]
  ヘッダ             <- 日付 `を` カレンダのヘッダに変換                             -- [String] -> [String]
  ヘッダ付き行リスト <-  ヘッダ `を` (日付行リスト `と連結`)                         -- [String] -> [String] -> [String]
  ヘッダ付き行リスト `を` 改行を挟んで連結して返す                                   -- [String] -> String

を :: a -> (a -> b) -> IO b
を a f = return $ f a

と連結 xs ys = ys ++ xs

改行を挟んで連結して返す = unlines

行毎の文字列に連結したリストに変換 = toLinesFromTokens
toLinesFromTokens :: [[String]] -> [String]
toLinesFromTokens = map (\ss -> drop 1 $ concat $ map padTok ss)
         -- 上でdrop 1しているのは
         -- 3桁左寄せしてから連結しているため、
         -- 各行の先頭に空白文字が１つ入るのが気に入らないため
  where
    padTok s = case length s of
                 0 -> "   "
                 1 -> "  " ++ s
                 2 -> " "  ++ s
                 _ -> error "unexpected token -> " ++ s

weekdayCount = 7
lineCharCountMax = weekdayCount * 3 - 1

カレンダのヘッダに変換 = toHeader
toHeader :: Day -> [String]
toHeader day = let s   = formatTime defaultTimeLocale "%B %Y" day
                   fst = unpack $ center lineCharCountMax ' ' $ pack s in
               [fst, "Su Mo Tu We Th Fr Sa"]

週毎の日付に分割して先頭週の開始曜日までは空文字を詰めたリストに変換 = toLeftPaddedMonthDayList
toLeftPaddedMonthDayList :: Day -> [[String]]
toLeftPaddedMonthDayList day = chunksOf 7 core
  where
    core = let fstDate = toMonthFirstDate day in
           (toLeftPaddableListFromMonthFirstDate fstDate) ++ (map show $ toMonthDateList day)

扱いやすい型に変換 = toDayFromZonedTime
toDayFromZonedTime :: ZonedTime -> Day
toDayFromZonedTime = utctDay . zonedTimeToUTC

指定日付が所属する月の全ての日付のリスト = toMonthDateList
toMonthDateList :: Day -> [Int]
toMonthDateList day = let (y,m,_) = toGregorian day
                          c = gregorianMonthLength y m in
                      [1..c]

指定日付が所属する月の先頭の週の、開始曜日までを埋める空文字のリスト = toLeftPaddableListFromMonthFirstDate
toLeftPaddableListFromMonthFirstDate :: Day -> [String]
toLeftPaddableListFromMonthFirstDate day = take (toWeekdayIndex day) $ repeat ""

指定日付が所属する月の先頭日付 = toMonthFirstDate
toMonthFirstDate :: Day -> Day
toMonthFirstDate day = let (y,m,_) = toGregorian day in
                       fromGregorian y m 1

日曜日を0としたときの曜日のインデックス = toWeekdayIndex
toWeekdayIndex :: Day -> Int
toWeekdayIndex day = case toWeekDate day of
                      (_,_,7) -> 0
                      (_,_,d) -> d