カレンダ整形問題：遊びのないHaskell版

MonthCalendar.hs

import Data.List
import Data.List.Split
import Data.Time.Calendar
import Data.Time.Calendar.WeekDate
import Data.Time.Format
import Data.Time.LocalTime

{- --------------------
  この関数がエントリポイント.
--------------------- -}
main = putStrLn =<< pure . formatToMonthCalendar =<< currentMonth

{- --------------------
   今回の本題.
   指定月のカレンダを整形する.
--------------------- -}
formatToMonthCalendar :: Month -> String
formatToMonthCalendar month =
  unlines $ [
    centering $ formatTime defaultTimeLocale "%B %Y" $ fromGregorian (aYear month) (aMonth month) 1
    , weekdayLabel
  ] ++ (map (concat . intersperse " " . map toS) $ toWeekDaysArray month)

{- "月"を表すデータ型 -}
data Month =
  Month {
    aYear :: Integer
  , aMonth :: Int
  } deriving (Show, Eq, Read)

{- 現在月を取得 -}
currentMonth :: IO Month
currentMonth = pure . toM . localDay . zonedTimeToLocalTime =<< getZonedTime
  where
    toM :: Day -> Month
    toM d = let (y,m,_) = toGregorian d
            in Month y m

{- 以降は作業用 -}
weekdayLabel = "Su Mo Tu We Th Fr Sa"

type WeekDays = [Maybe Day]

toWeekDaysArray :: Month -> [WeekDays]
toWeekDaysArray month =
  let offset = toWeekDayIndex $ toMonthFirstDay month
      allDays = (replicate offset Nothing) ++ (map Just $ toAllMonthDays month)
  in  chunksOf 7 allDays

toAllMonthDays :: Month -> [Day]
toAllMonthDays month = [toMonthFirstDay month .. toMonthLastDay month]

toMonthFirstDay :: Month -> Day
toMonthFirstDay (Month y m)=
  fromGregorian y m 1

toMonthLastDay :: Month -> Day
toMonthLastDay (Month y m) =
  fromGregorian y m $ gregorianMonthLength y m

toWeekDayIndex :: Day -> Int
toWeekDayIndex day =
  let (_, _, d) = toWeekDate day
  in  if d == 7
        then 0
        else d


centering :: String -> String
centering s =
  let len = (length weekdayLabel) - length s
      charCnt = floor (fromIntegral len / 2)
  in  replicate charCnt ' ' ++ s

toS :: Maybe Day -> String
toS Nothing = "  "
toS (Just day) = toS' day

toS' :: Day -> String
toS' day =
  let (_, _, d) = toGregorian day
  in  if d < 10
        then " " ++ (show d)
        else show d