{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}

-- |
-- Module: SwissEphemeris.Time
-- License: AGPL-3
-- Maintainer: swiss-ephemeris@lfborjas.com
-- Portability: POSIX
--
-- Functions and types for conversion between Haskell time types
-- and Swiss Ephemeris time values.
--
-- @since 1.4.0.0
module SwissEphemeris.Time
  ( -- * The many faces of time
    -- $timeDoc
    TimeStandard (..),
    JulianDay,
    JulianDayUT,
    JulianDayTT,
    JulianDayUT1,
    getJulianDay,
    SiderealTime,
    getSiderealTime,
    -- ** singletons
    SingTimeStandard(..),
    SingTSI(..),

    -- * Impure conversion typeclasses
    ToJulianDay (..),
    FromJulianDay (..),

    -- ** Wrapper for fail-able conversions
    ConversionResult,
    getConversionResult,

    -- * Pure utility functions
    mkJulianDay,
    coerceUT,
    julianNoon,
    julianMidnight,

    -- ** Impure conversion functions
    utcToJulianDays,
    -- ** Pure conversion functions
    -- *** Lossy conversion of a @Day@ value
    dayFromJulianDay,
    dayToJulianDay,
    -- *** 'Fake' (innacurate) conversions of datetime components
    gregorianToFakeJulianDayTT,
    gregorianFromFakeJulianDayTT,
    -- *** Lossy UT conversions of datetime components
    gregorianToJulianDayUT,
    gregorianFromJulianDayUT,
    -- *** Lossy UT conversions of an @UTC@ value
    utcToJulianDayUT,
    julianDayUTToUTC,
    -- (less ugly aliases)
    utcToJulian,
    julianToUTC,

    -- * Delta Time
    addDeltaTime,
    subtractDeltaTime,
    unsafeDeltaTime,
    deltaTime,
    safeDeltaTime,
    deltaTimeSE,
    universalToTerrestrial,
    universalToTerrestrialSafe,
    universalToTerrestrialSE,
    
    -- * Sidereal time
    julianToSiderealSimple,
    julianToSidereal
  )
where

import qualified Control.Monad.Fail as Fail
import Data.Time
import Foreign
import Foreign.C.String
import Foreign.SwissEphemeris
import SwissEphemeris.Internal
import System.IO.Unsafe (unsafePerformIO)
import Data.Kind (Type)

{- $timeDoc
   This module offers conversions between some Haskell time values, and astronomical
   time values as defined by @SwissEphemeris@. The most important types in this
   module are 'TimeStandard', which refers to different "standards" of time
   such as Universal Time and Terrestial Time, and 'JulianDay', which codifies
   an absolute floating point number of fractional "days" since an epoch
   in the distant past. A 'SiderealTime' is also provided, though it figures
   less prominently in the Swiss Ephemeris API, and the conversions are more
   self-explanatory.
   
   As far as this library is concerned, a [Julian Day](https://en.wikipedia.org/wiki/Julian_day)
   can represent either a moment in [Universal Time](https://en.wikipedia.org/wiki/Universal_Time),
   which takes into account the Earth's rotation (either the
   more specific @UT1@ standard, or a generic @UT@ time whose precision is left up
   to the caller -- we provide ways of converting a @UTCTime@ into a @JulianDayUT@, for example,)
   or [Terrestrial Time](https://en.wikipedia.org/wiki/Terrestrial_Time), which is independent of the Earth's rotation and is used
   in astronomical measurements from a theoretical point on the surface of the Earth.
   Most functionality in Swiss Ephemeris uses Terrestrial Time (the documentation
   also refers to it using the now-superseded moniker of Ephemeris Time, but current
   versions of the library actually don't use the time standard by that name, and instead
   adhere to TT.) 

   An absolute moment in time will /not/ be the same in UT1 and TT: TT is /ahead/ of
   UT1 by a quantity known as [Delta Time](https://en.wikipedia.org/wiki/%CE%94T_(timekeeping\)),
   which is not neatly predictable but which is expected to increase with the passage of time;
   given this reality, functions in this module make it mostly impossible to "coerce" a Julian Day
   obtained from a moment in Universal Time to Terrestrial Time (and vice-versa: ) Delta Time /must/ be calculated,
   and [leap seconds](https://en.wikipedia.org/wiki/Leap_second) in UT /must/ be taken into account. 
   Swiss Ephemeris provides functions to do these conversions safely by consulting historical data (hence the @IO@ restriction,)
   and the 'ToJulian' and 'FromJulian' typeclasses govern the interface for conversion for any
   given type: currently only @UTCTime@ from the Haskell time taxonomy is supported: a @Day@
   can trivially be first converted to/from @UTCTime@, and other values such as Haskell's
   own notion of @UniversalTime@ don't have immediate astronomical significance.
   
   The only somewhat "safe" coercion between time standards that doesn't go through IO
   is between @UT@ and @UT1@, though for @UTCTime@, this will be off by less than a second
   due to the nature of UTC vs. UT1. 
   
   For convenience, we provide a way of converting between 'Day' and any 'JulianDay' values purely,
   which relies on temporally unsound assumptions about the difference
   between the supported time standards; this works fine for dates, but is categorically
   wrong whenever a time of day is necessary. Go through the typeclass methods in that case.

   Some further reading:
   
   * https://wiki.haskell.org/Time
   * https://en.wikipedia.org/wiki/Terrestrial_Time
   * https://en.wikipedia.org/wiki/Universal_Time
   * https://en.wikipedia.org/wiki/Leap_second
   * https://en.wikipedia.org/wiki/%CE%94T_(timekeeping)
   * https://www.nist.gov/pml/time-and-frequency-division/time-realization/leap-seconds
   * https://www.ietf.org/timezones/data/leap-seconds.list

-}

-- | Various standards for measuring time that can be expressed as
-- Julian Days.
data TimeStandard
  = -- | Terrestrial Time (successor to Ephemeris Time)
    TT
  | -- | Universal Time, explicitly in its @UT1@ form.
    UT1
  | -- | Universal Time, in any of its forms; depending
    -- on how it was constructed (in most cases, UTC)
    UT
  deriving (TimeStandard -> TimeStandard -> Bool
(TimeStandard -> TimeStandard -> Bool)
-> (TimeStandard -> TimeStandard -> Bool) -> Eq TimeStandard
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeStandard -> TimeStandard -> Bool
$c/= :: TimeStandard -> TimeStandard -> Bool
== :: TimeStandard -> TimeStandard -> Bool
$c== :: TimeStandard -> TimeStandard -> Bool
Eq, Int -> TimeStandard -> ShowS
[TimeStandard] -> ShowS
TimeStandard -> String
(Int -> TimeStandard -> ShowS)
-> (TimeStandard -> String)
-> ([TimeStandard] -> ShowS)
-> Show TimeStandard
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeStandard] -> ShowS
$cshowList :: [TimeStandard] -> ShowS
show :: TimeStandard -> String
$cshow :: TimeStandard -> String
showsPrec :: Int -> TimeStandard -> ShowS
$cshowsPrec :: Int -> TimeStandard -> ShowS
Show)

----------------------------------------------------------
--- SINGLETONS
-- thanks to: https://blog.jle.im/entry/introduction-to-singletons-1.html
-- if this gets more use, consider using the 'singletons' package:
-- https://hackage.haskell.org/package/singletons-3.0
----------------------------------------------------------
-- | Singletons for pseudo-dependent type programming with
-- time standards. 
data SingTimeStandard :: TimeStandard -> Type where
  STT :: SingTimeStandard 'TT
  SUT1 :: SingTimeStandard 'UT1
  SUT :: SingTimeStandard 'UT
  
-- | Typeclass to recover the singleton for a given time standard
class SingTSI a where
  singTS :: SingTimeStandard a 

instance SingTSI 'TT where
  singTS :: SingTimeStandard 'TT
singTS = SingTimeStandard 'TT
STT
instance SingTSI 'UT1 where
  singTS :: SingTimeStandard 'UT1
singTS = SingTimeStandard 'UT1
SUT1
instance SingTSI 'UT where
  singTS :: SingTimeStandard 'UT
singTS = SingTimeStandard 'UT
SUT
 
-- | A @JulianDay@ can have different provenances, witnessed
-- by its accompanying phantom type:
--
-- * It could've been converted, purely, from a UTC value,
--   as such, its witness is 'UT'
-- * It could'be been produced by consulting tidal/leap second
--   information, as done by the Swiss Ephemeris library,
--   in which case it's 'TT' (aka, somewhat wrongly, as Ephemeris
--   time,) or 'UT1'.
newtype JulianDay (s :: TimeStandard) = MkJulianDay {
                                          -- | Get the underlying 'Double' in 
                                          -- a 'JulianDay'. We intentionally do /not/
                                          -- export a way to finagle a 'Double' into a
                                          -- 'JulianDay': you'll have to obtain it
                                          -- through the various temporal conversion functions.
                                          JulianDay s -> Double
getJulianDay :: Double}
  deriving (JulianDay s -> JulianDay s -> Bool
(JulianDay s -> JulianDay s -> Bool)
-> (JulianDay s -> JulianDay s -> Bool) -> Eq (JulianDay s)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (s :: TimeStandard). JulianDay s -> JulianDay s -> Bool
/= :: JulianDay s -> JulianDay s -> Bool
$c/= :: forall (s :: TimeStandard). JulianDay s -> JulianDay s -> Bool
== :: JulianDay s -> JulianDay s -> Bool
$c== :: forall (s :: TimeStandard). JulianDay s -> JulianDay s -> Bool
Eq, Int -> JulianDay s -> ShowS
[JulianDay s] -> ShowS
JulianDay s -> String
(Int -> JulianDay s -> ShowS)
-> (JulianDay s -> String)
-> ([JulianDay s] -> ShowS)
-> Show (JulianDay s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: TimeStandard). Int -> JulianDay s -> ShowS
forall (s :: TimeStandard). [JulianDay s] -> ShowS
forall (s :: TimeStandard). JulianDay s -> String
showList :: [JulianDay s] -> ShowS
$cshowList :: forall (s :: TimeStandard). [JulianDay s] -> ShowS
show :: JulianDay s -> String
$cshow :: forall (s :: TimeStandard). JulianDay s -> String
showsPrec :: Int -> JulianDay s -> ShowS
$cshowsPrec :: forall (s :: TimeStandard). Int -> JulianDay s -> ShowS
Show, Int -> JulianDay s
JulianDay s -> Int
JulianDay s -> [JulianDay s]
JulianDay s -> JulianDay s
JulianDay s -> JulianDay s -> [JulianDay s]
JulianDay s -> JulianDay s -> JulianDay s -> [JulianDay s]
(JulianDay s -> JulianDay s)
-> (JulianDay s -> JulianDay s)
-> (Int -> JulianDay s)
-> (JulianDay s -> Int)
-> (JulianDay s -> [JulianDay s])
-> (JulianDay s -> JulianDay s -> [JulianDay s])
-> (JulianDay s -> JulianDay s -> [JulianDay s])
-> (JulianDay s -> JulianDay s -> JulianDay s -> [JulianDay s])
-> Enum (JulianDay s)
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
forall (s :: TimeStandard). Int -> JulianDay s
forall (s :: TimeStandard). JulianDay s -> Int
forall (s :: TimeStandard). JulianDay s -> [JulianDay s]
forall (s :: TimeStandard). JulianDay s -> JulianDay s
forall (s :: TimeStandard).
JulianDay s -> JulianDay s -> [JulianDay s]
forall (s :: TimeStandard).
JulianDay s -> JulianDay s -> JulianDay s -> [JulianDay s]
enumFromThenTo :: JulianDay s -> JulianDay s -> JulianDay s -> [JulianDay s]
$cenumFromThenTo :: forall (s :: TimeStandard).
JulianDay s -> JulianDay s -> JulianDay s -> [JulianDay s]
enumFromTo :: JulianDay s -> JulianDay s -> [JulianDay s]
$cenumFromTo :: forall (s :: TimeStandard).
JulianDay s -> JulianDay s -> [JulianDay s]
enumFromThen :: JulianDay s -> JulianDay s -> [JulianDay s]
$cenumFromThen :: forall (s :: TimeStandard).
JulianDay s -> JulianDay s -> [JulianDay s]
enumFrom :: JulianDay s -> [JulianDay s]
$cenumFrom :: forall (s :: TimeStandard). JulianDay s -> [JulianDay s]
fromEnum :: JulianDay s -> Int
$cfromEnum :: forall (s :: TimeStandard). JulianDay s -> Int
toEnum :: Int -> JulianDay s
$ctoEnum :: forall (s :: TimeStandard). Int -> JulianDay s
pred :: JulianDay s -> JulianDay s
$cpred :: forall (s :: TimeStandard). JulianDay s -> JulianDay s
succ :: JulianDay s -> JulianDay s
$csucc :: forall (s :: TimeStandard). JulianDay s -> JulianDay s
Enum, Eq (JulianDay s)
Eq (JulianDay s)
-> (JulianDay s -> JulianDay s -> Ordering)
-> (JulianDay s -> JulianDay s -> Bool)
-> (JulianDay s -> JulianDay s -> Bool)
-> (JulianDay s -> JulianDay s -> Bool)
-> (JulianDay s -> JulianDay s -> Bool)
-> (JulianDay s -> JulianDay s -> JulianDay s)
-> (JulianDay s -> JulianDay s -> JulianDay s)
-> Ord (JulianDay s)
JulianDay s -> JulianDay s -> Bool
JulianDay s -> JulianDay s -> Ordering
JulianDay s -> JulianDay s -> JulianDay s
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (s :: TimeStandard). Eq (JulianDay s)
forall (s :: TimeStandard). JulianDay s -> JulianDay s -> Bool
forall (s :: TimeStandard). JulianDay s -> JulianDay s -> Ordering
forall (s :: TimeStandard).
JulianDay s -> JulianDay s -> JulianDay s
min :: JulianDay s -> JulianDay s -> JulianDay s
$cmin :: forall (s :: TimeStandard).
JulianDay s -> JulianDay s -> JulianDay s
max :: JulianDay s -> JulianDay s -> JulianDay s
$cmax :: forall (s :: TimeStandard).
JulianDay s -> JulianDay s -> JulianDay s
>= :: JulianDay s -> JulianDay s -> Bool
$c>= :: forall (s :: TimeStandard). JulianDay s -> JulianDay s -> Bool
> :: JulianDay s -> JulianDay s -> Bool
$c> :: forall (s :: TimeStandard). JulianDay s -> JulianDay s -> Bool
<= :: JulianDay s -> JulianDay s -> Bool
$c<= :: forall (s :: TimeStandard). JulianDay s -> JulianDay s -> Bool
< :: JulianDay s -> JulianDay s -> Bool
$c< :: forall (s :: TimeStandard). JulianDay s -> JulianDay s -> Bool
compare :: JulianDay s -> JulianDay s -> Ordering
$ccompare :: forall (s :: TimeStandard). JulianDay s -> JulianDay s -> Ordering
$cp1Ord :: forall (s :: TimeStandard). Eq (JulianDay s)
Ord)

 
-- Aliases for those who dislike datakinds

-- | A terrestrial time as a Julian Day
type JulianDayTT = JulianDay 'TT

-- | A generic universal time as a Julian Day
type JulianDayUT = JulianDay 'UT

-- | A @UT1@ universal time as a Julian Day
type JulianDayUT1 = JulianDay 'UT1

-- | Represents an instant in sidereal time
newtype SiderealTime = SiderealTime {SiderealTime -> Double
getSiderealTime:: Double}
  deriving (Int -> SiderealTime -> ShowS
[SiderealTime] -> ShowS
SiderealTime -> String
(Int -> SiderealTime -> ShowS)
-> (SiderealTime -> String)
-> ([SiderealTime] -> ShowS)
-> Show SiderealTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SiderealTime] -> ShowS
$cshowList :: [SiderealTime] -> ShowS
show :: SiderealTime -> String
$cshow :: SiderealTime -> String
showsPrec :: Int -> SiderealTime -> ShowS
$cshowsPrec :: Int -> SiderealTime -> ShowS
Show, SiderealTime -> SiderealTime -> Bool
(SiderealTime -> SiderealTime -> Bool)
-> (SiderealTime -> SiderealTime -> Bool) -> Eq SiderealTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SiderealTime -> SiderealTime -> Bool
$c/= :: SiderealTime -> SiderealTime -> Bool
== :: SiderealTime -> SiderealTime -> Bool
$c== :: SiderealTime -> SiderealTime -> Bool
Eq, Eq SiderealTime
Eq SiderealTime
-> (SiderealTime -> SiderealTime -> Ordering)
-> (SiderealTime -> SiderealTime -> Bool)
-> (SiderealTime -> SiderealTime -> Bool)
-> (SiderealTime -> SiderealTime -> Bool)
-> (SiderealTime -> SiderealTime -> Bool)
-> (SiderealTime -> SiderealTime -> SiderealTime)
-> (SiderealTime -> SiderealTime -> SiderealTime)
-> Ord SiderealTime
SiderealTime -> SiderealTime -> Bool
SiderealTime -> SiderealTime -> Ordering
SiderealTime -> SiderealTime -> SiderealTime
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SiderealTime -> SiderealTime -> SiderealTime
$cmin :: SiderealTime -> SiderealTime -> SiderealTime
max :: SiderealTime -> SiderealTime -> SiderealTime
$cmax :: SiderealTime -> SiderealTime -> SiderealTime
>= :: SiderealTime -> SiderealTime -> Bool
$c>= :: SiderealTime -> SiderealTime -> Bool
> :: SiderealTime -> SiderealTime -> Bool
$c> :: SiderealTime -> SiderealTime -> Bool
<= :: SiderealTime -> SiderealTime -> Bool
$c<= :: SiderealTime -> SiderealTime -> Bool
< :: SiderealTime -> SiderealTime -> Bool
$c< :: SiderealTime -> SiderealTime -> Bool
compare :: SiderealTime -> SiderealTime -> Ordering
$ccompare :: SiderealTime -> SiderealTime -> Ordering
$cp1Ord :: Eq SiderealTime
Ord)

-- | A type that encodes an attempt to convert between
-- temporal types. 
newtype ConversionResult dt = ConversionResult {ConversionResult dt -> Either String dt
getConversionResult :: Either String dt}
  deriving (Int -> ConversionResult dt -> ShowS
[ConversionResult dt] -> ShowS
ConversionResult dt -> String
(Int -> ConversionResult dt -> ShowS)
-> (ConversionResult dt -> String)
-> ([ConversionResult dt] -> ShowS)
-> Show (ConversionResult dt)
forall dt. Show dt => Int -> ConversionResult dt -> ShowS
forall dt. Show dt => [ConversionResult dt] -> ShowS
forall dt. Show dt => ConversionResult dt -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConversionResult dt] -> ShowS
$cshowList :: forall dt. Show dt => [ConversionResult dt] -> ShowS
show :: ConversionResult dt -> String
$cshow :: forall dt. Show dt => ConversionResult dt -> String
showsPrec :: Int -> ConversionResult dt -> ShowS
$cshowsPrec :: forall dt. Show dt => Int -> ConversionResult dt -> ShowS
Show, a -> ConversionResult b -> ConversionResult a
(a -> b) -> ConversionResult a -> ConversionResult b
(forall a b. (a -> b) -> ConversionResult a -> ConversionResult b)
-> (forall a b. a -> ConversionResult b -> ConversionResult a)
-> Functor ConversionResult
forall a b. a -> ConversionResult b -> ConversionResult a
forall a b. (a -> b) -> ConversionResult a -> ConversionResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ConversionResult b -> ConversionResult a
$c<$ :: forall a b. a -> ConversionResult b -> ConversionResult a
fmap :: (a -> b) -> ConversionResult a -> ConversionResult b
$cfmap :: forall a b. (a -> b) -> ConversionResult a -> ConversionResult b
Functor, Functor ConversionResult
a -> ConversionResult a
Functor ConversionResult
-> (forall a. a -> ConversionResult a)
-> (forall a b.
    ConversionResult (a -> b)
    -> ConversionResult a -> ConversionResult b)
-> (forall a b c.
    (a -> b -> c)
    -> ConversionResult a -> ConversionResult b -> ConversionResult c)
-> (forall a b.
    ConversionResult a -> ConversionResult b -> ConversionResult b)
-> (forall a b.
    ConversionResult a -> ConversionResult b -> ConversionResult a)
-> Applicative ConversionResult
ConversionResult a -> ConversionResult b -> ConversionResult b
ConversionResult a -> ConversionResult b -> ConversionResult a
ConversionResult (a -> b)
-> ConversionResult a -> ConversionResult b
(a -> b -> c)
-> ConversionResult a -> ConversionResult b -> ConversionResult c
forall a. a -> ConversionResult a
forall a b.
ConversionResult a -> ConversionResult b -> ConversionResult a
forall a b.
ConversionResult a -> ConversionResult b -> ConversionResult b
forall a b.
ConversionResult (a -> b)
-> ConversionResult a -> ConversionResult b
forall a b c.
(a -> b -> c)
-> ConversionResult a -> ConversionResult b -> ConversionResult c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ConversionResult a -> ConversionResult b -> ConversionResult a
$c<* :: forall a b.
ConversionResult a -> ConversionResult b -> ConversionResult a
*> :: ConversionResult a -> ConversionResult b -> ConversionResult b
$c*> :: forall a b.
ConversionResult a -> ConversionResult b -> ConversionResult b
liftA2 :: (a -> b -> c)
-> ConversionResult a -> ConversionResult b -> ConversionResult c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> ConversionResult a -> ConversionResult b -> ConversionResult c
<*> :: ConversionResult (a -> b)
-> ConversionResult a -> ConversionResult b
$c<*> :: forall a b.
ConversionResult (a -> b)
-> ConversionResult a -> ConversionResult b
pure :: a -> ConversionResult a
$cpure :: forall a. a -> ConversionResult a
$cp1Applicative :: Functor ConversionResult
Applicative, Applicative ConversionResult
a -> ConversionResult a
Applicative ConversionResult
-> (forall a b.
    ConversionResult a
    -> (a -> ConversionResult b) -> ConversionResult b)
-> (forall a b.
    ConversionResult a -> ConversionResult b -> ConversionResult b)
-> (forall a. a -> ConversionResult a)
-> Monad ConversionResult
ConversionResult a
-> (a -> ConversionResult b) -> ConversionResult b
ConversionResult a -> ConversionResult b -> ConversionResult b
forall a. a -> ConversionResult a
forall a b.
ConversionResult a -> ConversionResult b -> ConversionResult b
forall a b.
ConversionResult a
-> (a -> ConversionResult b) -> ConversionResult b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ConversionResult a
$creturn :: forall a. a -> ConversionResult a
>> :: ConversionResult a -> ConversionResult b -> ConversionResult b
$c>> :: forall a b.
ConversionResult a -> ConversionResult b -> ConversionResult b
>>= :: ConversionResult a
-> (a -> ConversionResult b) -> ConversionResult b
$c>>= :: forall a b.
ConversionResult a
-> (a -> ConversionResult b) -> ConversionResult b
$cp1Monad :: Applicative ConversionResult
Monad)

instance Fail.MonadFail ConversionResult where
  fail :: String -> ConversionResult a
fail = Either String a -> ConversionResult a
forall dt. Either String dt -> ConversionResult dt
ConversionResult (Either String a -> ConversionResult a)
-> (String -> Either String a) -> String -> ConversionResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left

-- | Conversion from a temporal value of type @from@
-- to a 'JulianDay' in the 'TimeStandard' @jd@.
-- It's bound to IO _and_ a containing 'MonadFail' since
-- in the general case, we need to interact with
-- the outside world, and may fail, when consulting
-- the necessary data.
-- How can it fail? In short: at least for valid temporal
-- values constructed via the @time@ library, pretty much only
-- if you have an old version of Swiss Ephemeris that's not aware
-- of a recent leap second. 
class Fail.MonadFail m => ToJulianDay m jd from where
  toJulianDay :: from -> IO (m (JulianDay jd))

instance Fail.MonadFail m => ToJulianDay m 'UT UTCTime where
  toJulianDay :: UTCTime -> IO (m (JulianDay 'UT))
toJulianDay = m (JulianDay 'UT) -> IO (m (JulianDay 'UT))
forall (m :: * -> *) a. Monad m => a -> m a
return (m (JulianDay 'UT) -> IO (m (JulianDay 'UT)))
-> (UTCTime -> m (JulianDay 'UT))
-> UTCTime
-> IO (m (JulianDay 'UT))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JulianDay 'UT -> m (JulianDay 'UT)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JulianDay 'UT -> m (JulianDay 'UT))
-> (UTCTime -> JulianDay 'UT) -> UTCTime -> m (JulianDay 'UT)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> JulianDay 'UT
utcToJulianDayUT

instance Fail.MonadFail m => ToJulianDay m 'UT1 UTCTime where
  toJulianDay :: UTCTime -> IO (m (JulianDay 'UT1))
toJulianDay = UTCTime -> IO (m (JulianDay 'UT1))
forall (m :: * -> *).
MonadFail m =>
UTCTime -> IO (m (JulianDay 'UT1))
utcToJulianUT1

instance Fail.MonadFail m => ToJulianDay m 'TT UTCTime where
  toJulianDay :: UTCTime -> IO (m (JulianDay 'TT))
toJulianDay = UTCTime -> IO (m (JulianDay 'TT))
forall (m :: * -> *).
MonadFail m =>
UTCTime -> IO (m (JulianDay 'TT))
utcToJulianTT

-- | Conversion from a 'JulianDay' in the 'TimeStandard'
-- @jd@ to a temporal value of type @to@
-- It's bound to IO since historical data may need to be consulted;
-- however, as per the underlying library, it /cannot/ fail.
class FromJulianDay jd to where
  fromJulianDay :: JulianDay jd -> IO to

instance FromJulianDay 'UT UTCTime where
  fromJulianDay :: JulianDay 'UT -> IO UTCTime
fromJulianDay = UTCTime -> IO UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> IO UTCTime)
-> (JulianDay 'UT -> UTCTime) -> JulianDay 'UT -> IO UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JulianDay 'UT -> UTCTime
julianDayUTToUTC

instance FromJulianDay 'UT1 UTCTime where
  fromJulianDay :: JulianDay 'UT1 -> IO UTCTime
fromJulianDay = JulianDay 'UT1 -> IO UTCTime
julianUT1ToUTC

instance FromJulianDay 'TT UTCTime where
  fromJulianDay :: JulianDay 'TT -> IO UTCTime
fromJulianDay = JulianDay 'TT -> IO UTCTime
julianTTToUTC

-------------------------------------------------------------------------------
-- UTILS
-------------------------------------------------------------------------------

-- | Constructor with chaperone: you have to provide a witness to a time standard
-- to produce a 'JulianDay' directly from a 'Double'. This is mostly
-- intended for internal use, if you find yourself using this function,
-- you're probably producing an unreliable value: consider using the
-- 'ToJulianDay' instance of a reliable temporal type
-- (like 'UTCTime',) before reaching for this function.
mkJulianDay :: SingTimeStandard ts -> Double -> JulianDay ts
mkJulianDay :: SingTimeStandard ts -> Double -> JulianDay ts
mkJulianDay SingTimeStandard ts
_ = Double -> JulianDay ts
forall (s :: TimeStandard). Double -> JulianDay s
MkJulianDay


-- | Coerce a value obtained directly from UTC (without
-- consulting historical data) into a UT1 Julian Day.
-- The difference should be less than 1 second, and
-- if you've used Haskell's own 'UTCTime' as the source
-- it /should/ be negligible for most use cases.
-- If you want to be precise... you'll have to go into 'IO'.
coerceUT :: JulianDay 'UT -> JulianDay 'UT1
coerceUT :: JulianDay 'UT -> JulianDay 'UT1
coerceUT (MkJulianDay Double
jd) = Double -> JulianDay 'UT1
forall (s :: TimeStandard). Double -> JulianDay s
MkJulianDay Double
jd

-- | Historically, Julian Days started at noon,
-- which is why the point with no fractional part
-- is noon (not midnight).
julianNoon :: JulianDay ts -> JulianDay ts
julianNoon :: JulianDay ts -> JulianDay ts
julianNoon (MkJulianDay Double
d) = Int -> JulianDay ts
forall a. Enum a => Int -> a
toEnum (Int -> JulianDay ts) -> (Double -> Int) -> Double -> JulianDay ts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> JulianDay ts) -> Double -> JulianDay ts
forall a b. (a -> b) -> a -> b
$ Double
d

-- | The half-day in Julian Days is midnight, so
-- midnight of a given date is halfway through the _previous_
-- day.
julianMidnight :: JulianDay ts -> JulianDay ts
julianMidnight :: JulianDay ts -> JulianDay ts
julianMidnight = Double -> JulianDay ts
forall (s :: TimeStandard). Double -> JulianDay s
MkJulianDay (Double -> JulianDay ts)
-> (JulianDay ts -> Double) -> JulianDay ts -> JulianDay ts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Num a => a -> a -> a
subtract Double
0.5 (Double -> Double)
-> (JulianDay ts -> Double) -> JulianDay ts -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JulianDay ts -> Double
forall (s :: TimeStandard). JulianDay s -> Double
getJulianDay (JulianDay ts -> Double)
-> (JulianDay ts -> JulianDay ts) -> JulianDay ts -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JulianDay ts -> JulianDay ts
forall (s :: TimeStandard). JulianDay s -> JulianDay s
julianNoon

-- | Add time to catch up UT to TT; doesn't make sense
-- for other time standards.
addDeltaTime :: JulianDay 'UT1 -> Double -> JulianDay 'TT
addDeltaTime :: JulianDay 'UT1 -> Double -> JulianDay 'TT
addDeltaTime (MkJulianDay Double
jd) Double
dt = Double -> JulianDay 'TT
forall (s :: TimeStandard). Double -> JulianDay s
MkJulianDay (Double
jd Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
dt)

-- | Subtract time to 'slow down' TT to UT; doesn't make
-- sense for other time standards.
subtractDeltaTime :: JulianDay 'TT -> Double -> JulianDay 'UT1
subtractDeltaTime :: JulianDay 'TT -> Double -> JulianDay 'UT1
subtractDeltaTime (MkJulianDay Double
jd) Double
dt = Double -> JulianDay 'UT1
forall (s :: TimeStandard). Double -> JulianDay s
MkJulianDay (Double
jd Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
dt)


-------------------------------------------------------------------------------
-- Lossy (pure, and /almost/ accurate for the contemporary timescale) conversions
-- for Day values.
-------------------------------------------------------------------------------

-- | Convenience "pure" function that pretends
-- that a day at noon can be converted to /any/ JulianDay;
-- in reality, it pretends that a JulianDay /in UT/ stands
-- in for any other (e.g. in 'UT1' or 'TT') -- this is "good enough"
-- for a day at noon since, at least in 2021, UT is only off
-- by less than a second from UT1, and only behind TT by a few
-- seconds 
dayToJulianDay :: Day -> JulianDay ts
dayToJulianDay :: Day -> JulianDay ts
dayToJulianDay Day
day =
  Integer -> Int -> Int -> Double -> JulianDay ts
forall (ts :: TimeStandard).
Integer -> Int -> Int -> Double -> JulianDay ts
gregorianToJulian Integer
y Int
m Int
d Double
12
  where
    (Integer
y, Int
m, Int
d) = Day -> (Integer, Int, Int)
toGregorian Day
day
    
-- | Convenience "pure" function that takes an arbitrary
-- 'JulianDay' value in any time standard, converts it to noon,
-- and then to the corresponding 'Day.' Exploits the same circumstantial
-- truths about time as 'dayToJulianDay'
dayFromJulianDay :: JulianDay ts -> Day
dayFromJulianDay :: JulianDay ts -> Day
dayFromJulianDay JulianDay ts
jd =
  Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d
  where
  (Integer
y,Int
m,Int
d,Double
_) = JulianDay ts -> (Integer, Int, Int, Double)
forall (ts :: TimeStandard).
JulianDay ts -> (Integer, Int, Int, Double)
gregorianFromJulianDay (JulianDay ts -> (Integer, Int, Int, Double))
-> (JulianDay ts -> JulianDay ts)
-> JulianDay ts
-> (Integer, Int, Int, Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JulianDay ts -> JulianDay ts
forall (s :: TimeStandard). JulianDay s -> JulianDay s
julianNoon (JulianDay ts -> (Integer, Int, Int, Double))
-> JulianDay ts -> (Integer, Int, Int, Double)
forall a b. (a -> b) -> a -> b
$ JulianDay ts
jd
  
-------------------------------------------------------------------------------
-- Lossy (but pure, and /almost/ accurate) conversion functions for UT values. 
-------------------------------------------------------------------------------

-- | Can produce a 'JulianDay' in any scale, but only values in 'UT'
-- are considered truthful. Hence the @fake@ moniker in the 'TT'
-- specialization, below.
gregorianToJulian :: Integer -> Int -> Int -> Double -> JulianDay ts
gregorianToJulian :: Integer -> Int -> Int -> Double -> JulianDay ts
gregorianToJulian Integer
year Int
month Int
day Double
hour =
  Double -> JulianDay ts
forall (s :: TimeStandard). Double -> JulianDay s
MkJulianDay (Double -> JulianDay ts)
-> (CDouble -> Double) -> CDouble -> JulianDay ts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (CDouble -> JulianDay ts) -> CDouble -> JulianDay ts
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> CInt -> CDouble -> GregFlag -> CDouble
c_swe_julday CInt
y CInt
m CInt
d CDouble
h GregFlag
gregorian
  where
    y :: CInt
y = Integer -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
year
    m :: CInt
m = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
month
    d :: CInt
d = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
day
    h :: CDouble
h = Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
hour
 
-- | Given components of a gregorian day (and time,)
-- produce a 'JulianDay' in the generic 'UT' time standard;
-- the precision of the resulting Julian Day will only be as good
-- as its input; if obtained by other means than via a 'UTCTime',
-- it's likely to be off by up to a second when compared with a 'UT1' value.
-- (on the other hand, it doesn't consult any data so it's not bound to 'IO')
-- This is provided for convenience, but if you have date components, you'd
-- be better off producing a valid 'UTCTime' to send to the 'toJulian'
-- family of functions, via e.g. [@fromGregorianValid@](https://hackage.haskell.org/package/time-1.12/docs/Data-Time-Calendar.html#v:fromGregorianValid)
-- and [@makeTimeOfDayValid@](https://hackage.haskell.org/package/time-1.12/docs/Data-Time-LocalTime.html#v:makeTimeOfDayValid)
gregorianToJulianDayUT :: Integer -> Int -> Int -> Double -> JulianDay 'UT
gregorianToJulianDayUT :: Integer -> Int -> Int -> Double -> JulianDay 'UT
gregorianToJulianDayUT = Integer -> Int -> Int -> Double -> JulianDay 'UT
forall (ts :: TimeStandard).
Integer -> Int -> Int -> Double -> JulianDay ts
gregorianToJulian
    
-- | If you care about accuracy, don't use this function!!! It's merely provided
-- as a facility for testing or situations where you don't really care about
-- the truth: the /actual/ Julian Day produced by this function is an absolute,
-- universal time, we just naughtily repackage it as a terrestrial time here.
-- If you want a /real/ TerrestrialTime, either convert a valid temporal value
-- through the 'toJulianDay' polymorphic function, or use 'universalToTerrestrial'
-- if you already have a 'UT1' value.
gregorianToFakeJulianDayTT :: Integer -> Int -> Int -> Double -> JulianDay 'TT
gregorianToFakeJulianDayTT :: Integer -> Int -> Int -> Double -> JulianDay 'TT
gregorianToFakeJulianDayTT = Integer -> Int -> Int -> Double -> JulianDay 'TT
forall (ts :: TimeStandard).
Integer -> Int -> Int -> Double -> JulianDay ts
gregorianToJulian


-- | Given a 'JulianDay' in any standard,
-- produce the date/time components of a gregorian date.
gregorianFromJulianDay :: JulianDay ts -> (Integer, Int, Int, Double)
gregorianFromJulianDay :: JulianDay ts -> (Integer, Int, Int, Double)
gregorianFromJulianDay (MkJulianDay Double
jd) =
  IO (Integer, Int, Int, Double) -> (Integer, Int, Int, Double)
forall a. IO a -> a
unsafePerformIO (IO (Integer, Int, Int, Double) -> (Integer, Int, Int, Double))
-> IO (Integer, Int, Int, Double) -> (Integer, Int, Int, Double)
forall a b. (a -> b) -> a -> b
$
    (Ptr CInt -> IO (Integer, Int, Int, Double))
-> IO (Integer, Int, Int, Double)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, Double))
 -> IO (Integer, Int, Int, Double))
-> (Ptr CInt -> IO (Integer, Int, Int, Double))
-> IO (Integer, Int, Int, Double)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
jyear -> (Ptr CInt -> IO (Integer, Int, Int, Double))
-> IO (Integer, Int, Int, Double)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, Double))
 -> IO (Integer, Int, Int, Double))
-> (Ptr CInt -> IO (Integer, Int, Int, Double))
-> IO (Integer, Int, Int, Double)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
jmon -> (Ptr CInt -> IO (Integer, Int, Int, Double))
-> IO (Integer, Int, Int, Double)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, Double))
 -> IO (Integer, Int, Int, Double))
-> (Ptr CInt -> IO (Integer, Int, Int, Double))
-> IO (Integer, Int, Int, Double)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
jday -> (Ptr CDouble -> IO (Integer, Int, Int, Double))
-> IO (Integer, Int, Int, Double)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CDouble -> IO (Integer, Int, Int, Double))
 -> IO (Integer, Int, Int, Double))
-> (Ptr CDouble -> IO (Integer, Int, Int, Double))
-> IO (Integer, Int, Int, Double)
forall a b. (a -> b) -> a -> b
$ \Ptr CDouble
jut -> do
      ()
_ <-
        CDouble
-> GregFlag
-> Ptr CInt
-> Ptr CInt
-> Ptr CInt
-> Ptr CDouble
-> IO ()
c_swe_revjul
          (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
jd)
          GregFlag
gregorian
          Ptr CInt
jyear
          Ptr CInt
jmon
          Ptr CInt
jday
          Ptr CDouble
jut
      CInt
year <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jyear
      CInt
month <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jmon
      CInt
day <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jday
      CDouble
time <- Ptr CDouble -> IO CDouble
forall a. Storable a => Ptr a -> IO a
peek Ptr CDouble
jut
      (Integer, Int, Int, Double) -> IO (Integer, Int, Int, Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
year, CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
month, CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
day, CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
time)

-- | Given a JulianDay in UT, produce the equivalent Gregorian date's components.
gregorianFromJulianDayUT :: JulianDay 'UT -> (Integer, Int, Int, Double)
gregorianFromJulianDayUT :: JulianDay 'UT -> (Integer, Int, Int, Double)
gregorianFromJulianDayUT = JulianDay 'UT -> (Integer, Int, Int, Double)
forall (ts :: TimeStandard).
JulianDay ts -> (Integer, Int, Int, Double)
gregorianFromJulianDay

-- | This is a bit of a misnomer: the "fake" value isn't the input,
-- it's the output: it produces a value as if the input was in UT, thus
-- running afoul of both leap seconds and delta time. Only useful
-- in contexts where accuracy is not valued. To get a somewhat more
-- trustworthy value, and still not have to go into 'IO', check out
-- 'dayFromJulianDay', which produces only the 'Day' part of a date.
gregorianFromFakeJulianDayTT :: JulianDay 'TT -> (Integer, Int, Int, Double)
gregorianFromFakeJulianDayTT :: JulianDay 'TT -> (Integer, Int, Int, Double)
gregorianFromFakeJulianDayTT = JulianDay 'TT -> (Integer, Int, Int, Double)
forall (ts :: TimeStandard).
JulianDay ts -> (Integer, Int, Int, Double)
gregorianFromJulianDay

picosecondsInHour :: Double
picosecondsInHour :: Double
picosecondsInHour = Double
3600 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1e12

-- | Given a 'UTCTime', produce a 'JulianDay' purely.
-- It can only be said to be in 'UT', since Haskell's
-- UTC is an approximation of 'UT1', off to up to a second.
-- If you want precision, use 'utcToJulianDays' (which returns
-- both the 'UT1' and 'TT' timestamps,) or 'utcToJulianUT1'.
-- Keep in mind though, that they're both in 'IO' /and/ may
-- return errors.
utcToJulianDayUT :: UTCTime -> JulianDay 'UT
utcToJulianDayUT :: UTCTime -> JulianDay 'UT
utcToJulianDayUT (UTCTime Day
day DiffTime
time) =
  Integer -> Int -> Int -> Double -> JulianDay 'UT
gregorianToJulianDayUT Integer
y Int
m Int
d Double
h
  where
    (Integer
y, Int
m, Int
d) = Day -> (Integer, Int, Int)
toGregorian Day
day
    h :: Double
h = (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
picosecondsInHour) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DiffTime -> Integer
diffTimeToPicoseconds DiffTime
time)

-- | Given a JulianDay in the vague 'UT' time standard,
-- produce a 'UTCTime' purely.
julianDayUTToUTC :: JulianDay 'UT -> UTCTime
julianDayUTToUTC :: JulianDay 'UT -> UTCTime
julianDayUTToUTC JulianDay 'UT
jd =
  Day -> DiffTime -> UTCTime
UTCTime Day
day DiffTime
dt
  where
    (Integer
y, Int
m, Int
d, Double
h) = JulianDay 'UT -> (Integer, Int, Int, Double)
gregorianFromJulianDayUT JulianDay 'UT
jd
    day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d
    dt :: DiffTime
dt = Integer -> DiffTime
picosecondsToDiffTime (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
picosecondsInHour

-- | See 'utcToJulianDayUT' -- this function is provided
-- for convenience in contexts where the ~1s accuracy gain
-- is not worth the more complicated type signature of
-- 'toJulian', but you'll get a "lesser" JulianDay
-- that's only as precise as its input.
utcToJulian :: UTCTime -> JulianDay 'UT
utcToJulian :: UTCTime -> JulianDay 'UT
utcToJulian = UTCTime -> JulianDay 'UT
utcToJulianDayUT

-- | See 'julianDayUTToUTC' -- this function is provided
-- for convenience in contexts where a slightly innacurate
-- JulianDay is worth it to stay in a pure context, otherwise,
-- see 'fromJulian'.
julianToUTC :: JulianDay 'UT -> UTCTime
julianToUTC :: JulianDay 'UT -> UTCTime
julianToUTC = JulianDay 'UT -> UTCTime
julianDayUTToUTC

-- | Utility function to split a 'UTCTime' into the constituent
-- parts expected by the underlying lib.
splitUTC :: UTCTime -> (Integer, Int, Int, TimeOfDay)
splitUTC :: UTCTime -> (Integer, Int, Int, TimeOfDay)
splitUTC (UTCTime Day
day DiffTime
time) =
  (Integer
y, Int
m, Int
d, TimeOfDay
tod)
  where
    (Integer
y, Int
m, Int
d) = Day -> (Integer, Int, Int)
toGregorian Day
day
    tod :: TimeOfDay
tod = DiffTime -> TimeOfDay
timeToTimeOfDay DiffTime
time

-------------------------------------------------------------------------------
-- UTC->(UT1,TT) functions
-------------------------------------------------------------------------------

-- | Convert a 'UTCTime' into a tuple of Terrestrial Time and UT1 Julian Days;
-- the underlying C function can return errors if:
--
-- * Any of the individual date components are invalid
-- * The given date has a leap second that it is not aware of (due to either
--   input error or the library not being out of date.)
--
-- A legitimately obtained 'UTCTime' (i.e. not crafted by hand, but by some means
-- of validated time input/ingestion) is very unlikely to error out in the former
-- of those scenarios, but there /is/ a chance it may fail in the latter; if you
-- encounter this, the first step would be to update the Swiss Ephemeris library,
-- since they bundle an array of leap seconds; otherwise, you can provide a file
-- called @seleapsec.txt@ in your configured ephemeris path,
-- see: [8.3.  Handling of leap seconds and the file seleapsec.txt](https://www.astro.com/swisseph/swephprg.htm#_Toc71121195)
utcToJulianDays :: Fail.MonadFail m => UTCTime -> IO (m (JulianDay 'TT, JulianDay 'UT1))
utcToJulianDays :: UTCTime -> IO (m (JulianDay 'TT, JulianDay 'UT1))
utcToJulianDays UTCTime
ut =
  let (Integer
y, Int
m, Int
d, TimeOfDay Int
h Int
mn Pico
s) = UTCTime -> (Integer, Int, Int, TimeOfDay)
splitUTC UTCTime
ut
   in Int
-> (Ptr CDouble -> IO (m (JulianDay 'TT, JulianDay 'UT1)))
-> IO (m (JulianDay 'TT, JulianDay 'UT1))
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
2 ((Ptr CDouble -> IO (m (JulianDay 'TT, JulianDay 'UT1)))
 -> IO (m (JulianDay 'TT, JulianDay 'UT1)))
-> (Ptr CDouble -> IO (m (JulianDay 'TT, JulianDay 'UT1)))
-> IO (m (JulianDay 'TT, JulianDay 'UT1))
forall a b. (a -> b) -> a -> b
$ \Ptr CDouble
dret -> (Ptr CChar -> IO (m (JulianDay 'TT, JulianDay 'UT1)))
-> IO (m (JulianDay 'TT, JulianDay 'UT1))
forall b. (Ptr CChar -> IO b) -> IO b
allocaErrorMessage ((Ptr CChar -> IO (m (JulianDay 'TT, JulianDay 'UT1)))
 -> IO (m (JulianDay 'TT, JulianDay 'UT1)))
-> (Ptr CChar -> IO (m (JulianDay 'TT, JulianDay 'UT1)))
-> IO (m (JulianDay 'TT, JulianDay 'UT1))
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
serr -> do
        CInt
retval <-
          CInt
-> CInt
-> CInt
-> CInt
-> CInt
-> CDouble
-> GregFlag
-> Ptr CDouble
-> Ptr CChar
-> IO CInt
c_swe_utc_to_jd
            (Integer -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mn)
            (Pico -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Pico
s)
            GregFlag
gregorian
            Ptr CDouble
dret
            Ptr CChar
serr

        if CInt
retval CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0
          then do
            String
msg <- Ptr CChar -> IO String
peekCAString Ptr CChar
serr
            m (JulianDay 'TT, JulianDay 'UT1)
-> IO (m (JulianDay 'TT, JulianDay 'UT1))
forall (m :: * -> *) a. Monad m => a -> m a
return (m (JulianDay 'TT, JulianDay 'UT1)
 -> IO (m (JulianDay 'TT, JulianDay 'UT1)))
-> m (JulianDay 'TT, JulianDay 'UT1)
-> IO (m (JulianDay 'TT, JulianDay 'UT1))
forall a b. (a -> b) -> a -> b
$ String -> m (JulianDay 'TT, JulianDay 'UT1)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
msg
          else do
            (CDouble
tt : CDouble
ut1 : [CDouble]
_) <- Int -> Ptr CDouble -> IO [CDouble]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
2 Ptr CDouble
dret
            m (JulianDay 'TT, JulianDay 'UT1)
-> IO (m (JulianDay 'TT, JulianDay 'UT1))
forall (m :: * -> *) a. Monad m => a -> m a
return (m (JulianDay 'TT, JulianDay 'UT1)
 -> IO (m (JulianDay 'TT, JulianDay 'UT1)))
-> m (JulianDay 'TT, JulianDay 'UT1)
-> IO (m (JulianDay 'TT, JulianDay 'UT1))
forall a b. (a -> b) -> a -> b
$ (JulianDay 'TT, JulianDay 'UT1)
-> m (JulianDay 'TT, JulianDay 'UT1)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> JulianDay 'TT
forall (s :: TimeStandard). Double -> JulianDay s
MkJulianDay (Double -> JulianDay 'TT)
-> (CDouble -> Double) -> CDouble -> JulianDay 'TT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (CDouble -> JulianDay 'TT) -> CDouble -> JulianDay 'TT
forall a b. (a -> b) -> a -> b
$ CDouble
tt, Double -> JulianDay 'UT1
forall (s :: TimeStandard). Double -> JulianDay s
MkJulianDay (Double -> JulianDay 'UT1)
-> (CDouble -> Double) -> CDouble -> JulianDay 'UT1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (CDouble -> JulianDay 'UT1) -> CDouble -> JulianDay 'UT1
forall a b. (a -> b) -> a -> b
$ CDouble
ut1)

utcToJulianTT :: Fail.MonadFail m => UTCTime -> IO (m (JulianDay 'TT))
utcToJulianTT :: UTCTime -> IO (m (JulianDay 'TT))
utcToJulianTT UTCTime
ut =
  ((JulianDay 'TT, JulianDay 'UT1) -> JulianDay 'TT)
-> m (JulianDay 'TT, JulianDay 'UT1) -> m (JulianDay 'TT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (JulianDay 'TT, JulianDay 'UT1) -> JulianDay 'TT
forall a b. (a, b) -> a
fst (m (JulianDay 'TT, JulianDay 'UT1) -> m (JulianDay 'TT))
-> IO (m (JulianDay 'TT, JulianDay 'UT1)) -> IO (m (JulianDay 'TT))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> IO (m (JulianDay 'TT, JulianDay 'UT1))
forall (m :: * -> *).
MonadFail m =>
UTCTime -> IO (m (JulianDay 'TT, JulianDay 'UT1))
utcToJulianDays UTCTime
ut

utcToJulianUT1 :: Fail.MonadFail m => UTCTime -> IO (m (JulianDay 'UT1))
utcToJulianUT1 :: UTCTime -> IO (m (JulianDay 'UT1))
utcToJulianUT1 UTCTime
ut =
  ((JulianDay 'TT, JulianDay 'UT1) -> JulianDay 'UT1)
-> m (JulianDay 'TT, JulianDay 'UT1) -> m (JulianDay 'UT1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (JulianDay 'TT, JulianDay 'UT1) -> JulianDay 'UT1
forall a b. (a, b) -> b
snd (m (JulianDay 'TT, JulianDay 'UT1) -> m (JulianDay 'UT1))
-> IO (m (JulianDay 'TT, JulianDay 'UT1))
-> IO (m (JulianDay 'UT1))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> IO (m (JulianDay 'TT, JulianDay 'UT1))
forall (m :: * -> *).
MonadFail m =>
UTCTime -> IO (m (JulianDay 'TT, JulianDay 'UT1))
utcToJulianDays UTCTime
ut

-------------------------------------------------------------------------------
-- (UT1,TT) -> UTC functions
-------------------------------------------------------------------------------

gregorianFromJulianDayTT :: JulianDay 'TT -> IO (Integer, Int, Int, TimeOfDay)
gregorianFromJulianDayTT :: JulianDay 'TT -> IO (Integer, Int, Int, TimeOfDay)
gregorianFromJulianDayTT (MkJulianDay Double
tt) = do
  (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
jyear -> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
jmon -> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
jday -> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$
    \Ptr CInt
jhour -> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
jmin -> (Ptr CDouble -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CDouble -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CDouble -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$ \Ptr CDouble
jsec -> do
      ()
_ <-
        CDouble
-> GregFlag
-> Ptr CInt
-> Ptr CInt
-> Ptr CInt
-> Ptr CInt
-> Ptr CInt
-> Ptr CDouble
-> IO ()
c_swe_jdet_to_utc
          (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
tt)
          GregFlag
gregorian
          Ptr CInt
jyear
          Ptr CInt
jmon
          Ptr CInt
jday
          Ptr CInt
jhour
          Ptr CInt
jmin
          Ptr CDouble
jsec
      CInt
year <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jyear
      CInt
month <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jmon
      CInt
day <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jday
      CInt
hour <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jhour
      CInt
minute <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jmin
      CDouble
second <- Ptr CDouble -> IO CDouble
forall a. Storable a => Ptr a -> IO a
peek Ptr CDouble
jsec
      (Integer, Int, Int, TimeOfDay) -> IO (Integer, Int, Int, TimeOfDay)
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
year,
          CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
month,
          CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
day,
          Int -> Int -> Pico -> TimeOfDay
TimeOfDay (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
hour) (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
minute) (CDouble -> Pico
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
second)
        )

gregorianFromJulianDayUT1 :: JulianDay 'UT1 -> IO (Integer, Int, Int, TimeOfDay)
gregorianFromJulianDayUT1 :: JulianDay 'UT1 -> IO (Integer, Int, Int, TimeOfDay)
gregorianFromJulianDayUT1 (MkJulianDay Double
ut1) = do
  (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
jyear -> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
jmon -> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
jday -> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$
    \Ptr CInt
jhour -> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CInt -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
jmin -> (Ptr CDouble -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CDouble -> IO (Integer, Int, Int, TimeOfDay))
 -> IO (Integer, Int, Int, TimeOfDay))
-> (Ptr CDouble -> IO (Integer, Int, Int, TimeOfDay))
-> IO (Integer, Int, Int, TimeOfDay)
forall a b. (a -> b) -> a -> b
$ \Ptr CDouble
jsec -> do
      ()
_ <-
        CDouble
-> GregFlag
-> Ptr CInt
-> Ptr CInt
-> Ptr CInt
-> Ptr CInt
-> Ptr CInt
-> Ptr CDouble
-> IO ()
c_swe_jdut1_to_utc
          (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
ut1)
          GregFlag
gregorian
          Ptr CInt
jyear
          Ptr CInt
jmon
          Ptr CInt
jday
          Ptr CInt
jhour
          Ptr CInt
jmin
          Ptr CDouble
jsec
      CInt
year <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jyear
      CInt
month <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jmon
      CInt
day <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jday
      CInt
hour <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jhour
      CInt
minute <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
jmin
      CDouble
second <- Ptr CDouble -> IO CDouble
forall a. Storable a => Ptr a -> IO a
peek Ptr CDouble
jsec
      (Integer, Int, Int, TimeOfDay) -> IO (Integer, Int, Int, TimeOfDay)
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
year,
          CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
month,
          CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
day,
          Int -> Int -> Pico -> TimeOfDay
TimeOfDay (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
hour) (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
minute) (CDouble -> Pico
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
second)
        )

julianTTToUTC :: JulianDay 'TT -> IO UTCTime
julianTTToUTC :: JulianDay 'TT -> IO UTCTime
julianTTToUTC JulianDay 'TT
tt = do
  (Integer
y, Int
m, Int
d, TimeOfDay
tod) <- JulianDay 'TT -> IO (Integer, Int, Int, TimeOfDay)
gregorianFromJulianDayTT JulianDay 'TT
tt
  UTCTime -> IO UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> IO UTCTime) -> UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d) (TimeOfDay -> DiffTime
timeOfDayToTime TimeOfDay
tod)

julianUT1ToUTC :: JulianDay 'UT1 -> IO UTCTime
julianUT1ToUTC :: JulianDay 'UT1 -> IO UTCTime
julianUT1ToUTC JulianDay 'UT1
ut1 = do
  (Integer
y, Int
m, Int
d, TimeOfDay
tod) <- JulianDay 'UT1 -> IO (Integer, Int, Int, TimeOfDay)
gregorianFromJulianDayUT1 JulianDay 'UT1
ut1
  UTCTime -> IO UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> IO UTCTime) -> UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d) (TimeOfDay -> DiffTime
timeOfDayToTime TimeOfDay
tod)

-------------------------------------------------------------------------------
-- Delta Time
-------------------------------------------------------------------------------

-- | Somewhat naïve delta time calculation: if no ephemeris
-- mode has been selected, it will use the default tidal
-- acceleration value as per the DE431 JPL ephemeris,
-- otherwise, it will use whatever ephemeris is currently set.
-- It's considered unsafe since switching ephemeris modes will
-- result in an incongruent delta time. See 'safeDeltaTime'
unsafeDeltaTime :: JulianDay 'UT1 -> IO Double
unsafeDeltaTime :: JulianDay 'UT1 -> IO Double
unsafeDeltaTime (MkJulianDay Double
jd) =
  CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (CDouble -> Double) -> IO CDouble -> IO Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CDouble -> IO CDouble
c_swe_deltat (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
jd)

-- | Alias for 'unsafeDeltaTime'
deltaTime :: JulianDay 'UT1 -> IO Double
deltaTime :: JulianDay 'UT1 -> IO Double
deltaTime = JulianDay 'UT1 -> IO Double
unsafeDeltaTime

-- | Same as 'deltaTime', but fails if the given 'EphemerisOption'
-- doesn't agree with the current ephemeris mode.
safeDeltaTime :: Fail.MonadFail m => EphemerisOption -> JulianDay 'UT1 -> IO (m Double)
safeDeltaTime :: EphemerisOption -> JulianDay 'UT1 -> IO (m Double)
safeDeltaTime EphemerisOption
epheOption (MkJulianDay Double
jd) =
  (Ptr CChar -> IO (m Double)) -> IO (m Double)
forall b. (Ptr CChar -> IO b) -> IO b
allocaErrorMessage ((Ptr CChar -> IO (m Double)) -> IO (m Double))
-> (Ptr CChar -> IO (m Double)) -> IO (m Double)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
serr -> do
    CDouble
dt <- CDouble -> EpheFlag -> Ptr CChar -> IO CDouble
c_swe_deltat_ex (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
jd) (EphemerisOption -> EpheFlag
ephemerisOptionToFlag EphemerisOption
epheOption) Ptr CChar
serr
    if CDouble
dt CDouble -> CDouble -> Bool
forall a. Ord a => a -> a -> Bool
< CDouble
0
      then do
        String
err <- Ptr CChar -> IO String
peekCAString Ptr CChar
serr
        m Double -> IO (m Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (m Double -> IO (m Double)) -> m Double -> IO (m Double)
forall a b. (a -> b) -> a -> b
$ String -> m Double
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
err
      else do
        m Double -> IO (m Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (m Double -> IO (m Double))
-> (CDouble -> m Double) -> CDouble -> IO (m Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> m Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> m Double) -> (CDouble -> Double) -> CDouble -> m Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (CDouble -> IO (m Double)) -> CDouble -> IO (m Double)
forall a b. (a -> b) -> a -> b
$ CDouble
dt

-- | Try to produce a delta time for the @SwissEphemeris@ ephemeris mode,
-- will fail if the current mode isn't set to @SwissEphemeris@.
deltaTimeSE :: Fail.MonadFail m => JulianDay 'UT1 -> IO (m Double)
deltaTimeSE :: JulianDay 'UT1 -> IO (m Double)
deltaTimeSE = EphemerisOption -> JulianDay 'UT1 -> IO (m Double)
forall (m :: * -> *).
MonadFail m =>
EphemerisOption -> JulianDay 'UT1 -> IO (m Double)
safeDeltaTime EphemerisOption
UseSwissEphemeris

-- | Convert between an instant in UT1 to TT, as a @JulianDay@, may
-- produce inaccurate results if an ephemeris mode isn't set explicitly.
universalToTerrestrial :: JulianDay 'UT1 -> IO (JulianDay 'TT)
universalToTerrestrial :: JulianDay 'UT1 -> IO (JulianDay 'TT)
universalToTerrestrial JulianDay 'UT1
jdut = do
  Double
deltaT <- JulianDay 'UT1 -> IO Double
unsafeDeltaTime JulianDay 'UT1
jdut
  JulianDay 'TT -> IO (JulianDay 'TT)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JulianDay 'TT -> IO (JulianDay 'TT))
-> JulianDay 'TT -> IO (JulianDay 'TT)
forall a b. (a -> b) -> a -> b
$ JulianDay 'UT1 -> Double -> JulianDay 'TT
addDeltaTime JulianDay 'UT1
jdut Double
deltaT

-- | Convert between an instant in UT1 to TT, as a @JulianDay@, using an explicit
-- ephemeris mode; fails if not currently working in the expected mode.
universalToTerrestrialSafe :: Fail.MonadFail m => EphemerisOption -> JulianDay 'UT1 -> IO (m (JulianDay 'TT))
universalToTerrestrialSafe :: EphemerisOption -> JulianDay 'UT1 -> IO (m (JulianDay 'TT))
universalToTerrestrialSafe EphemerisOption
eo JulianDay 'UT1
jdut = do
  m Double
deltaT <- EphemerisOption -> JulianDay 'UT1 -> IO (m Double)
forall (m :: * -> *).
MonadFail m =>
EphemerisOption -> JulianDay 'UT1 -> IO (m Double)
safeDeltaTime EphemerisOption
eo JulianDay 'UT1
jdut
  m (JulianDay 'TT) -> IO (m (JulianDay 'TT))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (JulianDay 'TT) -> IO (m (JulianDay 'TT)))
-> m (JulianDay 'TT) -> IO (m (JulianDay 'TT))
forall a b. (a -> b) -> a -> b
$ JulianDay 'UT1 -> Double -> JulianDay 'TT
addDeltaTime JulianDay 'UT1
jdut (Double -> JulianDay 'TT) -> m Double -> m (JulianDay 'TT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Double
deltaT

-- | 'universaltoTerrestrialSafe', set to @SwissEphemeris@
universalToTerrestrialSE :: Fail.MonadFail m => JulianDay 'UT1 -> IO (m (JulianDay 'TT))
universalToTerrestrialSE :: JulianDay 'UT1 -> IO (m (JulianDay 'TT))
universalToTerrestrialSE = EphemerisOption -> JulianDay 'UT1 -> IO (m (JulianDay 'TT))
forall (m :: * -> *).
MonadFail m =>
EphemerisOption -> JulianDay 'UT1 -> IO (m (JulianDay 'TT))
universalToTerrestrialSafe EphemerisOption
UseSwissEphemeris

-------------------------------------------------------------------------------
-- Sidereal Time
-------------------------------------------------------------------------------
--
-- | Given `JulianDay`, get `SiderealTime`. May consult ephemerides data, hence it being in IO,
-- will have to calculate obliquity at the given julian time, so it'll be slightly slower than
-- `calculateSiderealTime`.
julianToSiderealSimple :: JulianDay 'UT1 -> IO SiderealTime
julianToSiderealSimple :: JulianDay 'UT1 -> IO SiderealTime
julianToSiderealSimple (MkJulianDay Double
jt) = do
  CDouble
sidTime <- CDouble -> IO CDouble
c_swe_sidtime (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
jt)
  SiderealTime -> IO SiderealTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SiderealTime -> IO SiderealTime)
-> (Double -> SiderealTime) -> Double -> IO SiderealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> SiderealTime
SiderealTime (Double -> IO SiderealTime) -> Double -> IO SiderealTime
forall a b. (a -> b) -> a -> b
$ CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
sidTime

-- | Given a `JulianDay` and `ObliquityInformation`, calculate the equivalent `SiderealTime`.
-- prefer it over `calculateSiderealTimeSimple` if you already obtained `ObliquityInformation`
-- for another calculation.
julianToSidereal :: JulianDay 'UT1 -> ObliquityInformation -> IO SiderealTime
julianToSidereal :: JulianDay 'UT1 -> ObliquityInformation -> IO SiderealTime
julianToSidereal (MkJulianDay Double
jt) ObliquityInformation
on = do
  let obliq :: CDouble
obliq = Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CDouble) -> Double -> CDouble
forall a b. (a -> b) -> a -> b
$ ObliquityInformation -> Double
eclipticObliquity ObliquityInformation
on
      nut :: CDouble
nut = Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CDouble) -> Double -> CDouble
forall a b. (a -> b) -> a -> b
$ ObliquityInformation -> Double
nutationLongitude ObliquityInformation
on
  CDouble
sidTime <- CDouble -> CDouble -> CDouble -> IO CDouble
c_swe_sidtime0 (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
jt) CDouble
obliq CDouble
nut
  SiderealTime -> IO SiderealTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SiderealTime -> IO SiderealTime)
-> (Double -> SiderealTime) -> Double -> IO SiderealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> SiderealTime
SiderealTime (Double -> IO SiderealTime) -> Double -> IO SiderealTime
forall a b. (a -> b) -> a -> b
$ CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
sidTime

{- NOTES:

Given the following UTCTime:
2021-07-03 23:05:54.696005 UTC

if we ask for a UT JD:
jd <- toJulianDay now :: (IO (Maybe (JulianDay 'UT)))

we get:
Just (MkJulianDay {getJulianDay = 2459399.4624386113})

plugging into the nasa conversion tool (https://ssd.jpl.nasa.gov/tc.cgi#top)
they say:
2021-Jul-03 23:05:54.7

a ut1:
Just (MkJulianDay {getJulianDay = 2459399.46243737})
for Nasa:
2021-Jul-03 23:05:54.58

and a TT:
Just (MkJulianDay {getJulianDay = 2459399.463239352})

for Nasa:
2021-Jul-03 23:07:03.88

if we use the deltaT function for the UT1 ts:
deltaTime jdut1 -- (JulianDay 2459399.46243737)
we get:
8.019823376913656e-4

and then:
2459399.46243737 + 8.019823376913656e-4
should give us TT?
the result is:
2459399.463239352

which is exactly TT!!!
-}