]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Date/Read.hs
Ajout : profilage du code.
[comptalang.git] / lib / Hcompta / Date / Read.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 module Hcompta.Date.Read where
3
4 -- import Control.Applicative ((<$>))
5 import qualified Data.Time.Calendar as Time
6 import qualified Data.Time.LocalTime as Time
7 import Data.Time.LocalTime (TimeZone(..))
8 import Data.Typeable ()
9 import qualified Text.Parsec as R hiding
10 ( char
11 , anyChar
12 , crlf
13 , newline
14 , noneOf
15 , oneOf
16 , satisfy
17 , space
18 , spaces
19 , string
20 )
21 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
22
23 import Hcompta.Date (Date)
24 import qualified Hcompta.Lib.Parsec as R
25
26 data Error
27 = Error_year_or_day_is_missing
28 | Error_invalid_date (Integer, Int, Int)
29 | Error_invalid_time_of_day (Int, Int, Integer)
30 deriving (Eq, Show)
31
32 -- | Read a 'Date' in @[YYYY\/]MM\/DD [HH:MM[:SS][TZ]]@ format.
33 date
34 :: (Stream s (R.Error_State e m) Char, Monad m)
35 => (Error -> e) -> Maybe Integer -> ParsecT s u (R.Error_State e m) Date
36 date err def_year = (do
37 let read_2_or_1_digits = R.try (R.count 2 R.digit) <|> R.count 1 R.digit
38 n0 <- R.many1 R.digit
39 day_sep <- date_separator
40 n1 <- read_2_or_1_digits
41 n2 <- R.option Nothing $ R.try $ do
42 _ <- R.char day_sep
43 Just <$> read_2_or_1_digits
44 (year, m, d) <-
45 case (n2, def_year) of
46 (Nothing, Nothing) -> R.fail_with "date" (err $ Error_year_or_day_is_missing)
47 (Nothing, Just year) -> return (year, n0, n1)
48 (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d)
49 let month = fromInteger $ R.integer_of_digits 10 m
50 let dom = fromInteger $ R.integer_of_digits 10 d
51 day <- case Time.fromGregorianValid year month dom of
52 Nothing -> R.fail_with "date" (err $ Error_invalid_date (year, month, dom))
53 Just day -> return day
54 (hour, minu, sec, tz) <-
55 R.option (0, 0, 0, Time.utc) $ R.try $ do
56 R.skipMany1 $ R.space_horizontal
57 hour <- read_2_or_1_digits
58 sep <- hour_separator
59 minu <- read_2_or_1_digits
60 sec <- R.option Nothing $ R.try $ do
61 _ <- R.char sep
62 Just <$> read_2_or_1_digits
63 tz <- R.option Time.utc $ R.try $ do
64 R.skipMany $ R.space_horizontal
65 time_zone
66 return
67 ( fromInteger $ R.integer_of_digits 10 hour
68 , fromInteger $ R.integer_of_digits 10 minu
69 , maybe 0 (R.integer_of_digits 10) sec
70 , tz )
71 tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of
72 Nothing -> R.fail_with "date" (err $ Error_invalid_time_of_day (hour, minu, sec))
73 Just tod -> return tod
74 return $ Time.localTimeToUTC tz (Time.LocalTime day tod)
75 ) <?> "date"
76
77 -- | Parse the year, month and day separator: "/" or "-".
78 date_separator :: Stream s m Char => ParsecT s u m Char
79 date_separator = R.satisfy (\c -> c == '/' || c == '-')
80
81 -- | Parse the hour, minute and second separator: ":".
82 hour_separator :: Stream s m Char => ParsecT s u m Char
83 hour_separator = R.char ':'
84
85 -- | Parse either "-" into 'negate', or "+" or "" into 'id'.
86 sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
87 sign =
88 (R.char '-' >> return negate)
89 <|> (R.char '+' >> return id)
90 <|> return id
91
92 time_zone :: Stream s m Char => ParsecT s u m TimeZone
93 time_zone =
94 -- DOC: http://www.timeanddate.com/time/zones/
95 -- TODO: only a few time zones are suported below.
96 -- TODO: check the timeZoneSummerOnly values
97 R.choice
98 [ R.char 'A' >> R.choice
99 [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
100 , R.string "DT" >> return (TimeZone ((-3) * 60) True "ADT")
101 , return (TimeZone ((-1) * 60) False "A")
102 ]
103 , R.char 'B' >> R.choice
104 [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
105 , R.string "DT" >> return (TimeZone ((-10) * 60) True "BDT")
106 ]
107 , R.char 'C' >> R.choice
108 [ R.char 'E' >> R.choice
109 [ R.string "T" >> return (TimeZone ((1) * 60) True "CET")
110 , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
111 ]
112 , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
113 , R.string "DT" >> return (TimeZone ((-5) * 60) True "CDT")
114 ]
115 , R.char 'E' >> R.choice
116 [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
117 , R.string "DT" >> return (TimeZone ((-4) * 60) True "EDT")
118 ]
119 , R.string "GMT" >> return (TimeZone 0 False "GMT")
120 , R.char 'H' >> R.choice
121 [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
122 , R.string "DT" >> return (TimeZone (( -9) * 60) True "HDT")
123 ]
124 , R.char 'M' >> R.choice
125 [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
126 , R.string "DT" >> return (TimeZone ((-6) * 60) True "MDT")
127 , return (TimeZone ((-12) * 60) False "M")
128 ]
129 , R.char 'N' >> R.choice
130 [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
131 , return (TimeZone (1 * 60) False "N")
132 ]
133 , R.char 'P' >> R.choice
134 [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
135 , R.string "DT" >> return (TimeZone ((-7) * 60) True "PDT")
136 ]
137 , R.char 'Y' >> R.choice
138 [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
139 , R.string "DT" >> return (TimeZone ((-8) * 60) True "YDT")
140 , return (TimeZone (12 * 60) False "Y")
141 ]
142 , R.char 'Z' >> return (TimeZone 0 False "Z")
143 , time_zone_digits
144 ]
145
146 time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
147 {-# INLINEABLE time_zone_digits #-}
148 time_zone_digits = do
149 sign_ <- sign
150 hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
151 _ <- R.option ':' (R.char ':')
152 minute <- R.integer_of_digits 10 <$> R.count 2 R.digit
153 let tz = TimeZone
154 { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute)
155 , timeZoneSummerOnly = False
156 , timeZoneName = Time.timeZoneOffsetString tz
157 }
158 return tz