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