hsio.hs

#!/usr/bin/env stack
-- stack script --resolver lts-8.20 --package time,haskeline
module Main where

import Control.Monad.IO.Class
import Control.Monad
import Control.Exception
import System.Console.Haskeline
import Data.Time
import Data.Maybe
import System.Exit

main :: IO ()
main = runInputT defaultSettings app

app :: InputT IO ()
app = do
  name <- getName
  outputStrLn $ "Hello, " ++ name ++ "!"
  birthdayE <- getBirthday
  either (\_ -> do
            outputStrLn "Invalid birthday"
            liftIO $ exitWith (ExitFailure 2)
         )
         (\birthday -> do
            age <- calcAge birthday
            outputStrLn $ "You are " ++ age ++ " years old."
         )
         birthdayE

getName :: InputT IO String
getName = do
  minput <- getInputLine "Hello, what is your name?\n"
  return $ maybe "" id minput

getBirthday :: InputT IO (Either SomeException UTCTime)
getBirthday = do
  minput <- getInputLine "Birthday (format: dd/mm/yyyy, e.g.: 21/06/1985)\n"
  liftIO $ try $ parseTimeM False defaultTimeLocale "%d/%m/%Y" $ fromJust minput

calcAge :: UTCTime -> InputT IO String
calcAge birthday = do
  (ny, nm, nd) <- liftIO $ liftM (toGregorian . utctDay) getCurrentTime
  let (by, bm, bd) = toGregorian (utctDay birthday)
  let age = if (nm >= bm) && (nd >= bd) then (ny - by) else (ny - by - 1)
  return $ show age