src/Literate/Time.hs

   1 {-# LANGUAGE InstanceSigs #-}
   2 {-# OPTIONS_GHC -Wno-orphans #-}
   3
   4 module Literate.Time (
   5   module Data.Time.Calendar,
   6   module Data.Time.Calendar.Month,
   7   module Data.Time.Clock,
   8   module Data.Time.Format,
   9   module Data.Time.LocalTime,
  10 )
  11 where
  12
  13 import Data.Fixed (Pico)
  14 import Data.Foldable (asum, or)
  15 import Data.Maybe (fromJust)
  16 import Data.Time.Calendar
  17 import Data.Time.Calendar.Month
  18 import Data.Time.Clock
  19 import Data.Time.Format
  20 import Data.Time.LocalTime
  21 import Literate.Prelude
  22 import Prelude (error)
  23
  24 instance IsString LocalTime where
  25   fromString :: HasCallStack => String -> LocalTime
  26   fromString s =
  27     fromJust $
  28       asum @[]
  29         [ parseTimeM False timeLocales "%Y-%0m-%0dT%H:%M:%S" s
  30         , parseTimeM False timeLocales "%Y-%0m-%0d %H:%M:%S" s
  31         , parseTimeM False timeLocales "%Y-%0m-%0dT%H:%M" s
  32         , parseTimeM False timeLocales "%Y-%0m-%0d %H:%M" s
  33         , parseTimeM False timeLocales "%Y-%0m-%0d" s
  34         , parseTimeM False timeLocales "%Y-%0m" s
  35         , parseTimeM False timeLocales "%Y" s
  36         ]
  37 instance IsString Day where
  38   fromString :: HasCallStack => String -> Day
  39   fromString s =
  40     fromJust $
  41       asum @[]
  42         [ parseTimeM False timeLocales "%Y-%0m-%0d" s
  43         ]
  44 instance IsString TimeOfDay where
  45   fromString :: HasCallStack => String -> TimeOfDay
  46   fromString s =
  47     asum @[] @_ @DiffTime
  48       [ parseTimeM False timeLocales "%H" s
  49       , parseTimeM False timeLocales "%H:%M" s
  50       , parseTimeM False timeLocales "%H:%M:%S" s
  51       ]
  52       & fromJust
  53       & pastMidnight
  54
  55 timeLocales =
  56   defaultTimeLocale
  57     { knownTimeZones = knownTimeZones defaultTimeLocale <> [cet, cest]
  58     }
  59   where
  60     cet =
  61       TimeZone
  62         { timeZoneMinutes = 60
  63         , timeZoneSummerOnly = False
  64         , timeZoneName = "CET"
  65         }
  66     cest =
  67       TimeZone
  68         { timeZoneMinutes = 120
  69         , timeZoneSummerOnly = True
  70         , timeZoneName = "CEST"
  71         }
  72
  73 fromGregorianValid :: HasCallStack => Integer -> Int -> Int -> Day
  74 fromGregorianValid y m d =
  75   fromMaybe (error ("invalid Day: " <> show (y, m, d))) $
  76     Data.Time.Calendar.fromGregorianValid y m d
  77
  78 type Hour = Int
  79 type Minute = Int
  80 type Second = Pico
  81
  82 makeTimeOfDayValid :: HasCallStack => Hour -> Minute -> Second -> TimeOfDay
  83 makeTimeOfDayValid h m s =
  84   fromMaybe (error ("invalid TimeOfDay: " <> show (h, m, s))) $
  85     Data.Time.LocalTime.makeTimeOfDayValid h m s