hcalendar - print a calendar for a year

hcalendar.hs

#!/usr/bin/env stack
-- stack --resolver lts-8.23 runghc
-- may need to install --package time --package split 

-- A Haskell solution to the calendar printing problem.
-- See CppCon 2015: Eric Niebler "Ranges for the Standard Library"
--     https://www.youtube.com/watch?v=mFUXNMfaciE

module Main where

import Data.Time.Calendar
import Data.Function (on)
import Data.List
import Data.List.Split
import Control.Monad

main :: IO ()
main = emitCalendar 2017

daysForYear :: Integer -> [ Day ]
daysForYear y = [ fromGregorian y 1 1 .. fromGregorian y 12 31 ]

month :: Day -> Int
month day = case toGregorian day of (_, m, _) -> m

dayOfMonth :: Day -> Int
dayOfMonth day = case toGregorian day of (_, _, dm) -> dm

-- Sunday == 0
dayOfWeek :: Day -> Int
dayOfWeek day = fromIntegral (mod ((toModifiedJulianDay day) + 3) 7)

breaks :: (a -> Bool) -> [a] -> [[a]]
breaks p [] = []
breaks p xs = case break p xs of
               (as, [])   -> [as]
               (as, b:bs) -> (as ++ [b]) : breaks p bs

isSaturday :: Day -> Bool
isSaturday d = dayOfWeek d == 6

toWeeks :: [ Day ] -> [[Day]]
toWeeks days = case breaks isSaturday days of
                  []:rest  -> rest
                  x        -> x

lpad :: Int -> a -> [a] -> [a] 
lpad n a as = replicate k a ++ as
  where
    k = max 0 (n - length as)

rpad :: Int -> a -> [a] -> [a]
rpad n a as = as ++ (replicate k a)
  where k = max 0 (n - length as)

center :: Int -> String -> String
center width str = replicate left ' ' ++ str ++ replicate right ' '
  where n = length str
        left = div (width - n) 2
        right = width - n - left

fmtDay :: Day -> String
fmtDay day = lpad 3 ' ' (show (dayOfMonth day))

weekLineLength = 3*7

fmtWeek :: [Day] -> String
fmtWeek days
  | length days >= 7           = week 
  | dayOfMonth(head days) == 1 = lpad weekLineLength ' ' week
  | otherwise                  = rpad weekLineLength ' ' week
  where week = concatMap fmtDay days

monthNames = ["January", "February", "March", "April", "May", "June",
              "July", "August", "September", "October", "November", "December" ]

addMonthName :: String -> [String] -> [String]
addMonthName name rows = [ center weekLineLength name ] ++ rows

bottomAlign:: a -> [[a]] -> [[a]]
bottomAlign space xs = map (rpad n space) xs
  where n = maximum ( map length xs )

hcat :: [String] -> [String] -> [String]
hcat = zipWith (\x y -> x ++ "   " ++ y)

vcat :: [String] -> String
vcat = intercalate "\n" 

(|>) = flip ($)
infixl 7 |>
                                               
calendar year = daysForYear year               -- 1 x 365
         |> groupBy ((==) `on` month)          -- 12 x {28,30,31}
         |> map toWeeks                        -- 12 x {4,5,6} x 7
         |> map (map fmtWeek)                  -- 12 x {4,5,6}
         |> zipWith addMonthName monthNames    -- 12 x {5,6,7}
         |> chunksOf 3                         -- 4 x 3 x {5,6,7}
         |> map (bottomAlign (replicate weekLineLength ' '))  -- 4 x 3 x 6*
         |> map (vcat . foldr1 hcat)           -- 4
         |> intercalate "\n\n"                 -- 1

emitCalendar year = putStrLn (calendar year)