DslBuilderEff.hs

{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE QuantifiedConstraints #-}

module Bluefin.Internal.DslBuilderEff where

import Bluefin.Internal
import Bluefin.Internal.OneWayCoercible
  ( OneWayCoercible,
    oneWayCoerce,
    oneWayCoercible,
    oneWayCoercibleImpl,
  )
import GHC.Base (oneShot)
import GHC.IO (IO (IO))

newtype DslBuilderEff h es r
  = MkDslBuilderEff {unMkDslBuilderEff :: forall e. h e -> Eff (e :& es) r}

useImplDslBuilderEff ::
  (e <: es) =>
  DslBuilderEff h e r ->
  -- | ͘
  DslBuilderEff h es r
useImplDslBuilderEff = oneWayCoerce

runDslBuilderEff ::
  h es ->
  DslBuilderEff h es r ->
  -- | ͘
  Eff es r
runDslBuilderEff h f = makeOp (unMkDslBuilderEff f h)
{-# INLINE [0] runDslBuilderEff #-}
-- GHC's simplifier phase numbers count down toward 0. INLINE [0] keeps this
-- wrapper intact until phase 0, the final phase, so earlier simplifications
-- can work with the call before its body is exposed; it then strongly
-- encourages inlining to remove the wrapper. See
-- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/pragmas.html#phase-control

-- oneShot is essential for good performance. I don't fully understand
-- why.
dslBuilderEff ::
  (forall e. h e -> Eff (e :& es) r) ->
  -- | ͘
  DslBuilderEff h es r
dslBuilderEff f = MkDslBuilderEff $ \h -> case f h of
  UnsafeMkEff g -> UnsafeMkEff $ oneShot $ \env -> case g env of
    -- Expose IO's state transformer so it too can be marked one-shot
    IO io -> IO (oneShot io)

instance
  (e <: es) =>
  OneWayCoercible (DslBuilderEff h e r) (DslBuilderEff h es r)
  where
  oneWayCoercibleImpl = oneWayCoercible

instance (Handle h) => Functor (DslBuilderEff h es) where
  fmap f g =
    dslBuilderEff $ \h ->
      fmap f (runDslBuilderEff (mapHandle h) (useImplDslBuilderEff g))

instance (Handle h) => Applicative (DslBuilderEff h es) where
  pure x = dslBuilderEff (pure (pure x))
  f <*> x = dslBuilderEff $ \h ->
    runDslBuilderEff (mapHandle h) (useImplDslBuilderEff f)
      <*> runDslBuilderEff (mapHandle h) (useImplDslBuilderEff x)

instance (Handle h) => Monad (DslBuilderEff h es) where
  m >>= f = dslBuilderEff $ \h -> do
    r <- runDslBuilderEff (mapHandle h) (useImplDslBuilderEff m)
    runDslBuilderEff (mapHandle h) (useImplDslBuilderEff (f r))