Internal.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Fractal.Layer.Internal
-- Description : Internal implementation details for Fractal.Layer
-- Stability   : unstable
--
-- This module exposes the full internals of 'Layer', including the
-- @Layer@ constructor and @build@ record field. Import this only if
-- you are extending the library itself or building custom runners.
-- The API here may change between minor versions without notice.
--
-- For normal usage, import "Fractal.Layer" instead.
module Fractal.Layer.Internal
  ( -- * Core types
    Layer (..),
    LayerEnv (..),
    Service (..),

    -- * Type-safe map keyed by types
    TypeMap,
    DynF,
    emptyTypeMap,
    lookupTypeMap,
    insertTypeMap,

    -- * Service state
    ServiceState (..),

    -- * Low-level construction
    pureLayer,
    unsafeMkLayer,
  )
where

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Typeable
import qualified Type.Reflection as TR
import Control.Monad.Trans.Resource (ResourceT)
import Fractal.Layer.Interceptor (LayerInterceptor)
import UnliftIO (MVar, SomeException)

-------------------------------------------------------------------------------
-- Type-safe map keyed by types
--
-- Uses SomeTypeRep's Ord instance (fingerprint comparison) for O(log n)
-- lookups. Existential GADT witness eliminates unsafeCoerce.
-------------------------------------------------------------------------------

data DynF f where
  MkDynF :: !(TR.TypeRep a) -> f a -> DynF f

newtype TypeMap f = TypeMap (Map TR.SomeTypeRep (DynF f))

instance Semigroup (TypeMap f) where
  TypeMap a <> TypeMap b = TypeMap (a <> b)

instance Monoid (TypeMap f) where
  mempty = TypeMap Map.empty

emptyTypeMap :: TypeMap f
emptyTypeMap = TypeMap Map.empty

lookupTypeMap :: forall a f. Typeable a => TypeMap f -> Maybe (f a)
lookupTypeMap (TypeMap m) = do
  MkDynF rep v <- Map.lookup (TR.SomeTypeRep (TR.typeRep @a)) m
  TR.HRefl <- TR.eqTypeRep (TR.typeRep @a) rep
  pure v

insertTypeMap :: forall a f. Typeable a => f a -> TypeMap f -> TypeMap f
insertTypeMap v (TypeMap m) =
  TypeMap (Map.insert (TR.SomeTypeRep (TR.typeRep @a)) (MkDynF (TR.typeRep @a) v) m)

-------------------------------------------------------------------------------
-- Service state
-------------------------------------------------------------------------------

data ServiceState a
  = Initialized a
  | Failed SomeException

-------------------------------------------------------------------------------
-- Layer environment
-------------------------------------------------------------------------------

-- | Internal environment threaded through layer construction.
-- Carries the service cache and the active interceptor.
data LayerEnv m = LayerEnv
  { serviceStates :: !(MVar (TypeMap ServiceState))
  -- MVar rather than IORef because zipLayer runs sub-layers
  -- concurrently via async.  Two parallel layers calling `service`
  -- on the same Service must serialise the check-then-initialise
  -- sequence so only one thread performs initialisation and the
  -- other blocks until it completes.
  , interceptor :: !(LayerInterceptor m)
  }

-------------------------------------------------------------------------------
-- Layer
-------------------------------------------------------------------------------

-- | A recipe for producing an @env@ from @deps@, with managed
-- resource lifetimes.
--
-- Conceptually, @Layer m deps env ≈ deps -> m env@, but with
-- automatic resource tracking: every resource acquired during
-- construction is released when the layer's scope ends.
--
-- The @deps@ parameter makes dependencies explicit in the type. You
-- can inspect a layer's signature and know exactly what it needs
-- without reading the implementation. The compiler enforces that the
-- wiring is correct at every composition site.
--
-- @Layer@ implements many standard typeclasses, giving you a rich
-- vocabulary for composition:
--
-- * 'Monad': sequential resource threading via @do@-notation.
-- * 'Category': sequential composition via @>>>@.
-- * 'Arrow': parallel composition via @&&&@ and @***@.
-- * 'ArrowChoice': branching via @+++@ and @|||@.
-- * 'Profunctor': contramap inputs with 'lmap', map outputs with 'fmap'.
-- * 'Alternative': fallback with resource cleanup via @\<|\>@.
--
-- Construct layers with 'effect', 'resource', or 'bracketed'.
-- Run them with 'withLayer' or 'runLayer'.
newtype Layer m deps env = Layer
  { build :: LayerEnv m -> deps -> ResourceT m env
  -- ^ Build the layer inside 'ResourceT', acquiring any required
  --   resources and registering their corresponding finalizers.
  }

-------------------------------------------------------------------------------
-- Service
-------------------------------------------------------------------------------

-- | A layer tagged for singleton caching.  Create with 'mkService',
-- consume with 'service'.  The 'uncached' accessor retrieves the
-- original layer without caching behaviour.
newtype Service m deps env = Service
  { uncached :: Layer m deps env
  -- ^ The underlying layer, without caching.
  }

-------------------------------------------------------------------------------
-- Low-level construction
-------------------------------------------------------------------------------

-- | Construct a pure layer from a plain value. No effects, no cleanup.
--
-- Primarily used to implement 'pure' for the 'Applicative' instance.
-- In application code, 'effect' with a pure action is usually clearer:
--
-- @
-- -- these are equivalent:
-- pureLayer defaultConfig
-- effect (pure defaultConfig)
-- @
pureLayer :: Applicative m => env -> Layer m deps env
pureLayer env = Layer $ \_ -> const (pure env)

-- | Lowest-level smart constructor for effectful layers. Bypasses the
-- interceptor machinery, so operations built this way are invisible to
-- diagnostics and tracing. Prefer 'effect' or 'resource' when possible.
unsafeMkLayer :: (deps -> ResourceT m env) -> Layer m deps env
unsafeMkLayer f = Layer $ \_ -> f