カレンダ整形問題別解

MonthCalendar2.hs

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

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

{- --------------------
   今回の本題.
   指定月のカレンダを整形する.
--------------------- -}
formatToMonthCalendar :: Month -> String
formatToMonthCalendar month =
  let fst = toMonthFirstDay month
      pad = concat $ replicate (toWeekDayIndex fst) "   "
      cal = concatMap (\day -> case toWeekDayIndex day of
                 6 -> toS day ++ "\n"
                 otherwise -> toS day ++ " "
            ) [fst .. toMonthLastDay month]
  in  unlines [
    centering $ formatTime defaultTimeLocale "%B %Y" $ fromGregorian (aYear month) (aMonth month) 1
    , weekdayLabel
    , pad ++ cal
    ]

{- "月"を表すデータ型 -}
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"

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