@@ -0,0 +1,103 @@
1+-- | A clone in Haskell of the zdump(8) command, including most of
2+-- the bugs. This is useful for testing the Haskell implementation
3+-- of an Olson timezone parser and renderer against the reference
4+-- implementation in C. But less useful than it might seem at first,
5+-- because Haskell rounds historical solar mean timezones to the
6+-- nearest minute, whereas the C implementation rounds to the nearest
7+-- second.
8+module Main where
9+
10+import Data.Time.LocalTime.TimeZone.Series
11+import Data.Time.LocalTime.TimeZone.Olson.Types
12+import Data.Time.LocalTime.TimeZone.Olson.Parse
13+import Data.Time
14+import Data.Maybe (listToMaybe)
15+import System.Environment (getArgs)
16+import System.Exit (exitWith, exitSuccess, ExitCode(ExitFailure))
17+import System.Locale (defaultTimeLocale)
18+
19+version :: IO a
20+version = do
21+ putStrLn "hzdump version 0.1, clone of zdump 1.7 with -c option fixed"
22+ exitSuccess
23+
24+usage :: IO a
25+usage = do
26+ putStrLn "usage: hzdump [--version] [-v] [-c cutoff] zonename ..."
27+ exitWith $ ExitFailure 1
28+
29+illegalOpt :: Char -> IO a -- sic
30+illegalOpt opt = do
31+ putStrLn $ "hzdump: illegal option -- " ++ [opt]
32+ usage
33+
34+data Option = Version | Illegal Char | Verbose (Maybe Integer) | Now
35+ deriving (Eq, Ord, Show)
36+
37+main = do
38+ (opts, zones) <- fmap parseArgs getArgs
39+ (getTimes, displayTime) <- case opts of
40+ Version -> version
41+ Illegal opt -> illegalOpt opt
42+ Verbose yr -> return (transitionTimesUntil yr, displayVerbose)
43+ _ -> do now <- getCurrentTime
44+ return (const [now], displayConcise)
45+ tzss <- mapM getZone zones
46+ putStr . unlines . concat $
47+ zipWith (displayZone getTimes displayTime) zones tzss
48+ where
49+ getZone "-" = return utcTZ -- sic
50+ getZone z = getTimeZoneSeriesFromOlsonFile z
51+
52+ displayZone getTimes displayTime zone tzs =
53+ map ((zone ++) . (" " ++) . displayTime tzs) $ getTimes tzs
54+
55+parseArgs :: [String] -> (Option, [FilePath])
56+parseArgs args | "--version" `elem` args = (Version, [])
57+parseArgs args = getOpts False Nothing args
58+ where
59+ getOpts _ cutoff ("-v":args) = getOpts True cutoff args
60+ getOpts v Nothing ("-c":c:args) = maybe (Illegal 'c', [])
61+ (\y -> getOpts v (Just y) args) $
62+ maybeRead c
63+ getOpts v cutoff ("--":zones ) = (opts v cutoff, zones)
64+ getOpts _ _ (('-':x:_):_) = (Illegal x, [])
65+ getOpts v cutoff zones = (opts v cutoff, zones)
66+ opts v cutoff = if v then Verbose cutoff else Now
67+
68+displayConcise :: TimeZoneSeries -> UTCTime -> String
69+displayConcise tzs t = formatTime defaultTimeLocale format $
70+ ZoneSeriesTime t tzs
71+ where
72+ format = "%a %b %e %T %Y %Z"
73+
74+displayVerbose :: TimeZoneSeries -> UTCTime -> String
75+displayVerbose tzs t = concat [displayConcise utcTZ t, " = ",
76+ displayConcise tzs t, " isdst=", if isdst then "1" else "0"]
77+ where
78+ isdst = timeZoneSummerOnly $ timeZoneFromSeries tzs t
79+
80+transitionTimesUntil :: Maybe Integer -> TimeZoneSeries -> [UTCTime]
81+transitionTimesUntil yr =
82+ maybe id (dropWhile . (>=)) (fmap happyNewYear yr) .
83+ addBugs . addPrevSecond . actualTransitions
84+ where
85+ happyNewYear y = UTCTime (fromGregorian y 1 1) 0
86+ actualTransitions (TimeZoneSeries d cs) =
87+ let rs = reverse cs
88+ in map snd . filter fst $
89+ zipWith (\(t, tz) prevTz -> (tz /= prevTz, t))
90+ rs
91+ (d : map snd rs)
92+ addPrevSecond = concatMap (\t -> [(-1) `addUTCTime` t, t])
93+ addBugs = (bug0 ++) . (++ bug1) -- sic
94+ bug0 = [UTCTime (fromGregorian 1901 12 13) (20*3600+45*60+52),
95+ UTCTime (fromGregorian 1901 12 14) (20*3600+45*60+52)]
96+ bug1 = [UTCTime (fromGregorian 2038 1 18) ( 3*3600+14*60+ 7),
97+ UTCTime (fromGregorian 2038 1 19) ( 3*3600+14*60+ 7)]
98+
99+utcTZ :: TimeZoneSeries
100+utcTZ = TimeZoneSeries utc []
101+
102+maybeRead :: Read a => String -> Maybe a
103+maybeRead = fmap fst . listToMaybe . filter (null . snd) . reads