Recursion.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Recursion schemes for schema trees
--
-- This module provides proper categorical recursion schemes:
--
-- = Anamorphism (unfold)
--
-- An anamorphism builds a recursive structure from a seed using a coalgebra:
--
-- @
-- coalgebra :: a -> f a           -- one step of unfolding
-- ana :: Functor f => (a -> f a) -> a -> Fix f
-- ana coalg = Fix . fmap (ana coalg) . coalg
-- @
--
-- For effectful unfolding, we use 'anaM':
--
-- @
-- anaM :: (Monad m, Traversable f) => (a -> m (f a)) -> a -> m (Fix f)
-- @
--
-- = Catamorphism (fold)
--
-- A catamorphism collapses a recursive structure using an algebra:
--
-- @
-- algebra :: f a -> a             -- one step of folding
-- cata :: Functor f => (f a -> a) -> Fix f -> a
-- cata alg = alg . fmap (cata alg) . unFix
-- @
--
-- = Hylomorphism (unfold then fold)
--
-- A hylomorphism composes an anamorphism with a catamorphism:
--
-- @
-- hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
-- hylo alg coalg = cata alg . ana coalg
--                = alg . fmap (hylo alg coalg) . coalg  -- fused
-- @
--
-- The fused version never builds the intermediate structure!
module Synapse.Algebra.Recursion
  ( -- * Pure recursion schemes
    cata
  , ana
  , hylo
  , para
  , apo

    -- * Monadic recursion schemes
  , cataM
  , anaM
  , hyloM

    -- * Schema-specific operations
  , unfoldSchema
  , foldSchema
  , walkSchema

    -- * Re-exports
  , Fix(..)
  ) where

import Control.Monad (forM)
import Data.Text (Text)

import Synapse.Schema.Types (Path, PluginSchema(..), MethodSchema(..), ChildSummary(..))
import Synapse.Schema.Functor (SchemaF(..), Fix(..), SchemaTree)
import Synapse.Monad
import Synapse.Transport (fetchSchemaAt)

-- ============================================================================
-- Pure Recursion Schemes
-- ============================================================================

-- | Catamorphism: fold a recursive structure
--
-- @
-- cata alg = alg . fmap (cata alg) . unFix
-- @
cata :: Functor f => (f a -> a) -> Fix f -> a
cata alg = go
  where
    go (Fix fa) = alg (fmap go fa)

-- | Anamorphism: unfold to build a recursive structure
--
-- @
-- ana coalg = Fix . fmap (ana coalg) . coalg
-- @
ana :: Functor f => (a -> f a) -> a -> Fix f
ana coalg = go
  where
    go a = Fix (fmap go (coalg a))

-- | Hylomorphism: unfold then fold (fused - no intermediate structure)
--
-- @
-- hylo alg coalg = cata alg . ana coalg  -- unfused
--                = alg . fmap (hylo alg coalg) . coalg  -- fused
-- @
hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo alg coalg = go
  where
    go a = alg (fmap go (coalg a))

-- | Paramorphism: fold with access to original substructures
--
-- Like cata but the algebra also receives the original subtree
para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para alg = go
  where
    go (Fix fa) = alg (fmap (\x -> (x, go x)) fa)

-- | Apomorphism: unfold with early termination
--
-- Like ana but can short-circuit by returning Right with final value
apo :: Functor f => (a -> f (Either (Fix f) a)) -> a -> Fix f
apo coalg = go
  where
    go a = Fix (fmap (either id go) (coalg a))

-- ============================================================================
-- Monadic Recursion Schemes
-- ============================================================================

-- | Monadic catamorphism
--
-- Fold with effects at each step
cataM :: (Monad m, Traversable f) => (f a -> m a) -> Fix f -> m a
cataM alg = go
  where
    go (Fix fa) = do
      fa' <- traverse go fa  -- recursively process children
      alg fa'                 -- apply algebra to results

-- | Monadic anamorphism
--
-- Unfold with effects at each step. This is what we need for
-- schema tree building since fetching is effectful.
anaM :: (Monad m, Traversable f) => (a -> m (f a)) -> a -> m (Fix f)
anaM coalg = go
  where
    go a = do
      fa <- coalg a           -- one step of unfolding (effectful)
      fa' <- traverse go fa   -- recursively unfold children
      pure (Fix fa')

-- | Monadic hylomorphism
--
-- Unfold then fold, both with effects. Fused version.
hyloM :: (Monad m, Traversable f) => (f b -> m b) -> (a -> m (f a)) -> a -> m b
hyloM alg coalg = go
  where
    go a = do
      fa <- coalg a           -- unfold one step
      fb <- traverse go fa    -- recursively process
      alg fb                  -- fold one step

-- ============================================================================
-- Schema-Specific Operations
-- ============================================================================

-- | Coalgebra for unfolding schema trees
--
-- Given a path, fetch the schema and produce one layer of SchemaF
-- with child paths in the recursive positions.
schemaCoalgebra :: Path -> SynapseM (SchemaF Path)
schemaCoalgebra path = do
  schema <- fetchSchemaAt path
  let childPaths = case psChildren schema of
        Nothing -> []
        Just children -> [path ++ [csNamespace c] | c <- children]
  pure $ PluginF schema path childPaths

-- | Unfold a complete schema tree from a path
--
-- This is anaM applied to our schema coalgebra.
-- Builds the full tree structure by fetching all schemas.
unfoldSchema :: Path -> SynapseM SchemaTree
unfoldSchema = anaM schemaCoalgebra

-- | Fold a schema tree with an algebra
--
-- Pure fold - use this when you've already built the tree.
foldSchema :: (SchemaF a -> a) -> SchemaTree -> a
foldSchema = cata

-- | Walk the schema tree with a monadic hylomorphism
--
-- This is the main operation: unfold from a path, fold with an algebra.
-- Fused, so doesn't build intermediate tree in memory.
walkSchema :: (SchemaF a -> SynapseM a) -> Path -> SynapseM a
walkSchema alg = hyloM alg schemaCoalgebra