lib/Hcompta/Model/Date/Read.hs

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