calendar

gistfile1.hsc

import Data.Time.Clock
import Data.Time.Calendar
import Data.Time.LocalTime

-- TODO: printMonth with custom args
-- move printMonth to printCurrnentMonth

date :: IO (Integer,Int,Int) -- :: (year,month,day)
date = getZonedTime >>= return . toGregorian . localDay . zonedTimeToLocalTime
leap = date >>= (\(y,_,_) -> return $ isLeap y)
month = date >>= (\(y,m,_)-> return (y,m))

main = printMonth >>= (\x -> return x)

-- Days in one month
months = month >>= (\(y,m) -> 
  case m of
    1 -> return (y,m, 31)
    2 -> (leap >>= (\x -> if x then return (y,m, 29) else return (y,m,28)))
    3 -> return (y,m,31)
    4 -> return (y,m,30)
    5 -> return (y,m,31)
    6 -> return (y,m,30)
    7 -> return (y,m,31)
    8 -> return (y,m,31)
    9 -> return (y,m,30)
    10 -> return (y,m,31)
    11 -> return (y,m,30)
    12 -> return (y,m,31)
 )

-- (y,m,d) - year, month, total days
curmonth :: IO [Integer]
curmonth = months >>= (\(y,m,d) -> return (zfill (fstDay y (toInteger m)) [1 .. d]))

getMonth :: IO [[Integer]]
getMonth = curmonth >>= (\xs -> return (monthMatrix xs []))

printMonth :: IO ()
printMonth = getMonth >>= (\xs -> putStrLn $ joinLines $ map lineToStr xs)

monthMatrix :: [t] -> [[t]] -> [[t]]
monthMatrix [] acc = reverse acc
monthMatrix xs acc = monthMatrix (drop 7 xs) ((take 7 xs):acc)

-- Fill "empty days" with zeros (so it is easy to replace them with whitespaces)
zfill :: Integer -> [Integer] -> [Integer]
zfill 0 xs = xs
zfill n xs = zfill (n-1) (0:xs)

-- Integer line to string 
lineToStr :: (Ord t, Num t) => [t] -> [Char]
lineToStr xs = lineToStr' xs []

lineToStr' :: (Ord t, Num t) => [t] -> [Char] -> [Char]
lineToStr' [] acc = acc
lineToStr' (x:xs) acc
  | (x == 0) = lineToStr' xs ("   " ++ acc)
  | otherwise = lineToStr' xs (reverse (show x) ++ digits)
  where 
    -- One digit is two spaces, two digits one
    digits =  (if x>=10 then " " else "  ") ++ acc

--Join lines
joinLines :: [String] -> [Char]
joinLines xs = joinLines' xs []

joinLines' :: [String] -> [Char] -> [Char]
joinLines' [] acc = " Mo Tu We Th Fr Sa Su" ++ (reverse acc)
joinLines' (x:xs) acc = joinLines' xs (x ++ ('\n' : acc))


-- Leap year algorithm
isLeap :: Integral a => a -> Bool
isLeap year 
  | year `mod` 400 == 0 = True
  | year `mod` 100 == 0  = False
  | year `mod` 4 == 0 = True
  | otherwise = False

-- General method for calculating weekday
-- year, month, day
dayOfWeek :: Integer -> Integer -> Integer -> Integer
dayOfWeek y m d = ((y `div` 3) - (y `div` 100) + (y `div` 400) + d + (mcode y m) - 1) `mod` 7

fstDay :: Integer -> Integer -> Integer
fstDay y m = dayOfWeek y m 1

mcode :: Integer -> Integer -> Integer
mcode y m = 
  case m of
    1 -> if (isLeap y) then 6 else 0
    2 -> if (isLeap y) then 2 else 3
    3 -> 3
    4 -> 6
    5 -> 1
    6 -> 4
    7 -> 6
    8 -> 2
    9 -> 5
    10 -> 0
    11 -> 3
    12 -> 5