lib/Hcompta/Model/Date/Read.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 module Hcompta.Model.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.Model.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