{-# Language ImportQualifiedPost #-}
{-|
Module      : Advent.Fix
Description : Newtype for building recursive datatypes
Copyright   : (c) Eric Mertens, 2021
License     : ISC
Maintainer  : emertens@gmail.com

-}
module Advent.Fix where

import Data.Functor.Classes (showsPrec1, Show1)
import Data.Map (Map)
import Data.Map qualified as Map

-- | Fixed-point of a type
newtype Fix f = Fix { forall (f :: * -> *). Fix f -> f (Fix f)
unFix :: f (Fix f) }

instance Show1 f => Show (Fix f) where
  showsPrec :: Int -> Fix f -> ShowS
showsPrec Int
p (Fix f (Fix f)
x) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
      (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Fix "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> f (Fix f) -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1 Int
11 f (Fix f)
x

-- | Generic fold
cata :: Functor t => (t a -> a) -> Fix t -> a
cata :: forall (t :: * -> *) a. Functor t => (t a -> a) -> Fix t -> a
cata t a -> a
f (Fix t (Fix t)
x) = t a -> a
f ((Fix t -> a) -> t (Fix t) -> t a
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((t a -> a) -> Fix t -> a
forall (t :: * -> *) a. Functor t => (t a -> a) -> Fix t -> a
cata t a -> a
f) t (Fix t)
x)

-- | Generic monadic fold
cataM :: Monad m => Traversable t => (t a -> m a) -> Fix t -> m a
cataM :: forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
cataM t a -> m a
f (Fix t (Fix t)
x) = t a -> m a
f (t a -> m a) -> m (t a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Fix t -> m a) -> t (Fix t) -> m (t a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse ((t a -> m a) -> Fix t -> m a
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
cataM t a -> m a
f) t (Fix t)
x

-- | Generic unfold
ana :: Functor f => (a -> f a) -> (a -> Fix f)
ana :: forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
ana a -> f a
f = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> Fix f) -> (a -> f (Fix f)) -> a -> Fix f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Fix f) -> f a -> f (Fix f)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> f a) -> a -> Fix f
forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
ana a -> f a
f) (f a -> f (Fix f)) -> (a -> f a) -> a -> f (Fix f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
f

-- | Convert a map of values parameterized by names into a recursively
-- defined datatype.
anaFromMap ::
  (Ord k, Functor f) =>
  Map k (f k) {- ^ entries by name                          -} ->
  k           {- ^ root name                                -} ->
  Fix f       {- ^ root node with keys recursively resolved -}
anaFromMap :: forall k (f :: * -> *).
(Ord k, Functor f) =>
Map k (f k) -> k -> Fix f
anaFromMap Map k (f k)
m = (k -> f k) -> k -> Fix f
forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
ana (Map k (f k)
m Map k (f k) -> k -> f k
forall k a. Ord k => Map k a -> k -> a
Map.!)