Programming Praxis - Cal

Happy new year everyone!

In today’s Programming Praxis exercise we have to implement the Unix utility cal, which prints calendars. Let’s get started.

First we need a bunch of imports:

import Data.List
import Data.List.Split
import qualified Data.Text as T
import Data.Time
import System.Environment
import System.Locale

Let’s start by determining which days are in a given month.

days :: Integer -> Int -> [Day]
days y m = map (fromGregorian y m) [1..gregorianMonthLength y m]

We’re going to need to do a bunch of date formatting, and since the required locale is fairly long we make a quick helper function.

fmt :: FormatTime t => String -> t -> String
fmt = formatTime defaultTimeLocale

On to the real meat of the application: the function that creates the calendar for the given year and month. Basically, just build the header, start printing the day numbers at the correct weekday by prepending some spaces, and also put some blank spaces at the end so that each month is 6 rows high. This is needed so that when we start printing months next to each other everything stays in the correct place.

monthCal :: Integer -> Int -> String
monthCal y m = unlines $ (T.unpack . (T.center 20 ' ') . T.pack .
    fmt "%B %Y" $ fromGregorian y m 1) : "Su Mo Tu We Th Fr Sa" :
    (map unwords . take 6 . chunk 7 $
        replicate (read . fmt "%w" . head $ days y m) "  " ++
        map (fmt "%e") (days y m) ++ repeat "  ")

Showing multiple months next to each other requires some string manipulation.

showCal :: [String] -> IO ()
showCal = putStrLn . unlines . map (unlines . map
            (intercalate "  ") . transpose . map lines) . chunk 3

Finally, we need a function to determine which months to show when the -3 argument is used.

surround :: UTCTime -> [String]
surround d = map ((\(y, m, _) -> monthCal y m) . toGregorian .
               (`addGregorianMonthsRollOver` utctDay d)) [-1..1]

All that’s left to do is to check the arguments and show the appropriate calendar.

main :: IO ()
main = do args <- getArgs
          now  <- getCurrentTime
          let (curYear, curMonth) = read $ fmt "(%Y,%m)" now
          case args of
              [y,m]  -> showCal [monthCal (read y) (read m)]
              ["-3"] -> showCal $ surround now
              [y]    -> showCal $ map (monthCal $ read y) [1..12]
              []     -> showCal [monthCal curYear curMonth]
              _      -> error "Invalid parameters"

About these ads

Tags: bonsai, cal, calendar, code, hakell, kata, praxis, programming