lib/Hcompta/Filter/Date/Read.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 module Hcompta.Filter.Date.Read where
   3
   4 import           Control.Monad (Monad(..))
   5 import           Data.Bool
   6 import           Data.Char (Char)
   7 import           Data.Eq (Eq(..))
   8 import           Data.Functor ((<$>))
   9 import           Data.Maybe (Maybe(..), maybe)
  10 import qualified Data.Time.Calendar  as Time
  11 import qualified Data.Time.LocalTime as Time
  12 import           Data.Time.LocalTime (TimeZone(..))
  13 import           Data.Typeable ()
  14 import qualified Text.Parsec as R hiding
  15                   ( char
  16                   , anyChar
  17                   , crlf
  18                   , newline
  19                   , noneOf
  20                   , oneOf
  21                   , satisfy
  22                   , space
  23                   , spaces
  24                   , string
  25                   )
  26 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  27 import           Prelude (($), Int, Integer, Num(..), Show(..), id)
  28
  29 import           Hcompta.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 <- R.char 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.char '_'
  63                         hour <- read_2_or_1_digits
  64                         sep <- R.char 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 $
  70                                 time_zone
  71                         return
  72                          ( fromInteger $ R.integer_of_digits 10 hour
  73                          , fromInteger $ R.integer_of_digits 10 minu
  74                          , maybe 0      (R.integer_of_digits 10) sec
  75                          , tz )
  76         tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of
  77          Nothing  -> R.fail_with "date" (err $ Error_invalid_time_of_day (hour, minu, sec))
  78          Just tod -> return tod
  79         return $ Time.localTimeToUTC tz (Time.LocalTime day tod)
  80         ) <?> "date"
  81
  82 -- | Separator for year, month and day: "-".
  83 date_separator :: Char
  84 date_separator = '-'
  85
  86 -- | Separator for hour, minute and second: ":".
  87 hour_separator :: Char
  88 hour_separator = ':'
  89
  90 -- | Parse either "-" into 'negate', or "+" or "" into 'id'.
  91 sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
  92 sign =
  93             (R.char '-' >> return negate)
  94         <|> (R.char '+' >> return id)
  95         <|> return id
  96
  97 time_zone :: Stream s m Char => ParsecT s u m TimeZone
  98 time_zone =
  99         -- DOC: http://www.timeanddate.com/time/zones/
 100         -- TODO: only a few time zones are suported below.
 101         -- TODO: check the timeZoneSummerOnly values
 102         R.choice
 103          [ R.char '_' >>
 104                 R.choice
 105                  [ R.char 'A' >> R.choice
 106                          [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
 107                          , R.string "DT" >> return (TimeZone ((-3) * 60) True  "ADT")
 108                          , return (TimeZone ((-1) * 60) False "A")
 109                          ]
 110                  , R.char 'B' >> R.choice
 111                          [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
 112                          , R.string "DT" >> return (TimeZone ((-10) * 60) True  "BDT")
 113                          ]
 114                  , R.char 'C' >> R.choice
 115                          [ R.char 'E' >> R.choice
 116                                  [ R.string "T"  >> return (TimeZone ((1) * 60) True  "CET")
 117                                  , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
 118                                  ]
 119                          , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
 120                          , R.string "DT" >> return (TimeZone ((-5) * 60) True  "CDT")
 121                          ]
 122                  , R.char 'E' >> R.choice
 123                          [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
 124                          , R.string "DT" >> return (TimeZone ((-4) * 60) True  "EDT")
 125                          ]
 126                  , R.string "GMT" >> return (TimeZone 0 False "GMT")
 127                  , R.char 'H' >> R.choice
 128                          [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
 129                          , R.string "DT" >> return (TimeZone (( -9) * 60) True  "HDT")
 130                          ]
 131                  , R.char 'M' >> R.choice
 132                          [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
 133                          , R.string "DT" >> return (TimeZone ((-6) * 60) True  "MDT")
 134                          , return (TimeZone ((-12) * 60) False "M")
 135                          ]
 136                  , R.char 'N' >> R.choice
 137                          [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
 138                          , return (TimeZone (1 * 60) False "N")
 139                          ]
 140                  , R.char 'P' >> R.choice
 141                          [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
 142                          , R.string "DT" >> return (TimeZone ((-7) * 60) True  "PDT")
 143                          ]
 144                  , R.char 'Y' >> R.choice
 145                          [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
 146                          , R.string "DT" >> return (TimeZone ((-8) * 60) True  "YDT")
 147                          , return (TimeZone (12 * 60) False "Y")
 148                          ]
 149                  , R.char 'Z' >> return (TimeZone 0 False "Z")
 150                  ]
 151          , time_zone_digits
 152          ]
 153
 154 time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
 155 {-# INLINEABLE time_zone_digits #-}
 156 time_zone_digits = do
 157         sign_ <- sign
 158         hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
 159         minute <-
 160                 R.option 0 $ do
 161                         _ <- R.char ':'
 162                         R.integer_of_digits 10 <$> R.count 2 R.digit
 163         let tz = TimeZone
 164                  { timeZoneMinutes    = sign_ (fromInteger hour * 60 + fromInteger minute)
 165                  , timeZoneSummerOnly = False
 166                  , timeZoneName       = Time.timeZoneOffsetString tz
 167                  }
 168         return tz