Move to an effects system

[lfborjas]

Helps with testability, composability, etc. I'm using fused-effects in another project, our current major effects would look like this:

data EphemerisData (m :: Type -> Type) k where
  GetPlanetPosition :: Planet -> JulianTime -> EphemerisData m (Either String EclipticPosition)
  GetHouseCusps     :: HouseSystem -> JulianTime -> GeographicPosition -> EphemerisData m CuspsCalculation
  GetObliquity      :: JulianTime -> EphemerisData m (Either String ObliquityInformation )

getPlanetPosition :: Has EphemerisData sig m => Planet -> JulianTime -> m (Either String EclipticPosition)
getPlanetPosition p t = send $ GetPlanetPosition p t

getHouseCusps :: Has EphemerisData sig m => HouseSystem -> JulianTime -> GeographicPosition -> m CuspsCalculation
getHouseCusps hs t p = send $ GetHouseCusps hs t p

getObliquity :: Has EphemerisData sig m => JulianTime -> m (Either String ObliquityInformation)
getObliquity = send . GetObliquity

data TimeZoneData (m :: Type -> Type) k where
  TimeAtPointToUTC :: Double -> Double -> LocalTime -> TimeZoneData m UTCTime
{- ORMOLU_DISABLE -}

timeAtPointToUTC :: Has TimeZoneData sig m => Double -> Double -> LocalTime -> m UTCTime
timeAtPointToUTC lt lg localTime = send $ TimeAtPointToUTC lt lg localTime


newtype EphemerisDataIOC m a = EphemerisDataIOC {runEphemerisDataIO :: m a}
  deriving (Applicative, Functor, Monad, MonadIO, MonadFail)

instance (MonadIO m, Algebra sig m) => Algebra (EphemerisData :+: sig) (EphemerisDataIOC m) where
  alg hdl sig ctx = case sig of
    L (GetPlanetPosition p t) -> (<$ ctx) <$> liftIO (calculateEclipticPosition t p)
    L (GetHouseCusps hs t p)  -> (<$ ctx) <$> liftIO (calculateCusps hs t p)
    L (GetObliquity  t)       -> (<$ ctx) <$> liftIO (calculateObliquity t)
    R other -> EphemerisDataIOC (alg (runEphemerisDataIO . hdl) other ctx)


instance (MonadIO m, Algebra sig m)
  => Algebra (TimeZoneData :+: sig) (TimeZoneDataIOC m) where
  alg hdl sig ctx = TimeZoneDataIOC $ case sig of
    L (TimeAtPointToUTC lt lg localTime) -> do
      db <- ask
      (<$ ctx) <$> liftIO (TZD.timeAtPointToUTC db lt lg localTime)
    R other -> alg (runTimeZoneDataIO . hdl) (R other) ctx

newtype TimeZoneDataIOC  m a = TimeZoneDataIOC {runTimeZoneDataIO :: ReaderC TZD.TimeZoneDatabase  m a}
  deriving (Applicative, Functor, Monad, MonadIO, MonadFail)

runTimeZoneDataWithDB :: TZD.TimeZoneDatabase -> TimeZoneDataIOC m a -> m a
runTimeZoneDataWithDB db = runReader db . runTimeZoneDataIO

Note that the timezone runner only knows about the timezone database pointer in the TimeZoneDataIOC carrier, actual usage of the effect is none the wiser. Here's some example usage:

testHoroscope :: (Has EphemerisData sig m, Has TimeZoneData sig m, MonadFail m) => m HoroscopeData
testHoroscope = do
  let birthplace = Location "Tegucigalpa" (Latitude 14.0839053) (Longitude $ -87.2750137)
  birthtime <- parseTimeM True defaultTimeLocale "%Y-%-m-%-d %T" "1989-01-06 00:00:00"
  horoscope (BirthData birthplace birthtime)

renderTestChart :: IO ()
renderTestChart =
  withEphemerisData (appConfigFolder defaultConfig) $
    withTimeZoneData (appTimeZoneFile defaultConfig) $ \tzdb ->
      render
      & runTimeZoneDataWithDB tzdb
      & runEphemerisDataIO
  where
    render = do
      horoscope' <- testHoroscope
      liftIO $ Svg.renderToFile (basePath <> "radix.svg") $ Radix.renderChart [] 400 horoscope'

Note that horoscope now doesn't care about the timezone database or about opening the ephemeris path -- all of that happens when actually running in an effectful context (in this case, IO.)

The Servant story is a bit more complicated, but feasible, too.