Last active
December 17, 2015 07:29
-
-
Save jabaraster/5573528 to your computer and use it in GitHub Desktop.
カレンダー整形問題のHaskell版回答。IOで汚染される範囲を狭くすることにこだわった。
http://blog.jnito.com/entry/2013/05/01/082049
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Main where | |
import Data.List.Split | |
import Data.Time.Calendar | |
import Data.Time.Calendar.WeekDate | |
import Data.Time.Clock | |
import Data.Time.Format | |
import Data.Time.LocalTime | |
import Data.Text (pack, unpack, center) | |
import System.Locale | |
main = getZonedTime >>= return . render >>= putStrLn | |
weekdayCount = 7 | |
lineCharCountMax = weekdayCount * 3 - 1 | |
render :: ZonedTime -> String | |
render time = let day = toDayFromZonedTime time -- ZonedTime -> Day | |
days = toLeftPaddedMonthDayList day -- Day -> [[String]] | |
daysLines = toLinesFromTokens days -- [[String]] -> [String] | |
lines = toHeader day ++ daysLines in -- [String] -> [String] | |
unlines lines -- [String] -> String | |
toLinesFromTokens :: [[String]] -> [String] | |
toLinesFromTokens = map (\ss -> drop 1 $ concat $ map padTok ss) | |
-- 上でdrop 1しているのは | |
-- 3桁左寄せしてから連結しているため、 | |
-- 各行の先頭に空白文字が1つ入るのが気に入らないため | |
where | |
padTok s = case length s of | |
0 -> " " | |
1 -> " " ++ s | |
2 -> " " ++ s | |
_ -> error "unexpected token -> " ++ s | |
toHeader :: Day -> [String] | |
toHeader day = let s = formatTime defaultTimeLocale "%B %Y" day | |
fst = unpack $ center lineCharCountMax ' ' $ pack s in | |
[fst, "Su Mo Tu We Th Fr Sa"] | |
toLeftPaddedMonthDayList :: Day -> [[String]] | |
toLeftPaddedMonthDayList day = chunksOf 7 core | |
where | |
core = let fstDate = toMonthFirstDate day in | |
(toLeftPaddableListFromMonthFirstDate fstDate) ++ (map show $ toMonthDateList day) | |
toDayFromZonedTime :: ZonedTime -> Day | |
toDayFromZonedTime = utctDay . zonedTimeToUTC | |
toMonthDateList :: Day -> [Int] | |
toMonthDateList day = let (y,m,_) = toGregorian day | |
c = gregorianMonthLength y m in | |
[1..c] | |
toLeftPaddableListFromMonthFirstDate :: Day -> [String] | |
toLeftPaddableListFromMonthFirstDate day = take (toWeekdayIndex day) $ repeat "" | |
toMonthFirstDate :: Day -> Day | |
toMonthFirstDate day = let (y,m,_) = toGregorian day in | |
fromGregorian y m 1 | |
toWeekdayIndex :: Day -> Int | |
toWeekdayIndex day = case toWeekDate day of | |
(_,_,7) -> 0 | |
(_,_,d) -> d |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
GHCでコンパイルしてみたら、色々ブラッシュアップ出来たので修正版を再掲!