haskell勉強用プログラムその…2?

5/10に酔った勢いで書いた一発ネタプログラムです。おそらくhaskell初めて2つめとか3つめのプログラム。
基本以下の2つしか計算しないという単純なモノです。

• 日付と日付の間の日数計算
• ある日付から日数経過後の日付

使用方法は限定しないので、どんどん好きなように。

公開はしたけれど、後悔はしてない。

module LAdjust where 
import Prelude
import Text.ParserCombinators.Parsec 
import Data.Char
import Control.Exception as Exp hiding (try, catch)
    
data Date = K{ year :: Int, month:: Int,  day :: Int }

instance Show Date where
    show (K y m d) = show y ++ "/" ++ show m ++ "/" ++ show d

dateParse :: Parser (Date)
dateParse = do y <- many1 digit
               string "/"
               m <- many1 digit
               string "/"
               d <- many1 digit
               return (K (atoi y) (atoi m) (atoi d))
    where atoi l = foldl (\a b -> (a*10)+digitToInt b) 0 l

isLeapY year = if (year `mod` 4 == 0 && year `mod` 100 /= 0 ||
                        year `mod` 400 == 0) then True else False

getMDay year = [0, 31, if isLeapY year then 29 else 28, 31, 30, 31, 30, 31, 31, 
                     30, 31, 30, 31] 
getYDay year = foldl (\x y -> x + y) 0 (getMDay year)

getMD year (m1, d1) (m2, d2) = if m1 == m2 then d2 - d1 else d3
    where m' m1 m2 k = if m1 == m2 then k
                       else m' (m1+1) m2 (((getMDay year) !! m1) + k)
          d3 = ((getMDay year) !! m1) - d1 + d2 + m' m1 (m2-1) 0

calcDate (K y1 m1 d1) (K y2 m2 d2) = 
    if y1 == y2 then getMD y1 (m1, d1) (m2, d2)
    else getMD y1 (m1, d1) (12, 31) + calcY (y1+1) y2 0 + 
         getMD y2 (1,1) (m2, d2)
    where calcY y1 y2 k = if y1 == y2 then k 
                          else calcY (y1+1) y2 (k + getYDay y1)

getDay str1 str2 = calcDate d1 d2 
    where d1 = case parse dateParse  "" str1 of
                 Left err -> throw (ErrorCall "parse error")
                 Right xs -> xs
          d2 = case parse dateParse  "" str2 of
                 Left err -> throw (ErrorCall "parse error")
                 Right xs -> xs

plusDay k 0 = k
plusDay (K y1 m1 d1) days = 
    if (days > yend) then  plusDay (K (y1+1) 1 1) (days - yend)
    else if (days > mend) then
             plusDay (K y1 (m1+1) 1) (days - mend - 1)
         else (K y1 m1 (d1+days))
    where yend = getMD y1 (m1, d1) (12,31)
          mend = getMD y1 (m1, d1) (m1, (getMDay y1) !! m1)

plus str1 d = plusDay d1 d
    where d1 = case parse dateParse  "" str1 of
                 Left err -> throw (ErrorCall "parse error")
                 Right xs -> xs

-- usage: ans "1949/5/3" "1978/9/9" "1979/9/14"
ans str1 str2 str3 = plus str3 (getDay str1 str2)