{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Module      : Data.Diagram
-- Copyright   : (c) Eddie Jones 2020
-- License     : BSD-3
-- Maintainer  : eddiejones2108@gmail.com
-- Stability   : experimental
--
-- This module contains a 'Free' /monad/ with shared subterms.
-- Unfortunately it is not a true monad in /Hask/ category.
-- If the classical Free monad generalises a tree, here we generalise directed acylic graphs.
-- The 'Diagram' is the true monadic context in which all operations are run.
--
-- For most operations to work the functor must be of class 'Eq1', 'Hashable1' and 'Traversable'.
module Data.Diagram
  ( -- * Diagrams
    Diagram,
    runDiagram,
    compress,

    -- * Nodes
    Free (Pure),
    free,
    fromFree,
    retract,

    -- * Combinators
    map,
    bind,
    fold,
  )
where

import Control.Monad.State hiding (foldM)
import Data.Functor.Classes
import Data.Functor.Identity
import qualified Data.HashMap.Lazy as H
import Data.Hashable
import Data.Hashable.Lifted
import qualified Data.IntMap as I
import GHC.Generics (Generic)
import Prelude hiding (lookup, map)

-- | The diagram records overlapping terms:
--
--      * @f@ is the functor from which the Free terms are build.
--
--      * @a@ is the type of leaves or terminals.
--
--      * @s@ is a phantom type labelling the diagram and preventing leaking.
newtype Diagram f a s m r = Diagram
  { Diagram f a s m r
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) m r
getState ::
      StateT
        ( Int, -- Fresh node ID
          H.HashMap (Free_ f a s) Int, -- node to ID
          I.IntMap (Free_ f a s) -- ID to node
        )
        m
        r
  }
  deriving (a -> Diagram f a s m b -> Diagram f a s m a
(a -> b) -> Diagram f a s m a -> Diagram f a s m b
(forall a b. (a -> b) -> Diagram f a s m a -> Diagram f a s m b)
-> (forall a b. a -> Diagram f a s m b -> Diagram f a s m a)
-> Functor (Diagram f a s m)
forall a b. a -> Diagram f a s m b -> Diagram f a s m a
forall a b. (a -> b) -> Diagram f a s m a -> Diagram f a s m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (f :: * -> *) a s (m :: * -> *) a b.
Functor m =>
a -> Diagram f a s m b -> Diagram f a s m a
forall (f :: * -> *) a s (m :: * -> *) a b.
Functor m =>
(a -> b) -> Diagram f a s m a -> Diagram f a s m b
<$ :: a -> Diagram f a s m b -> Diagram f a s m a
$c<$ :: forall (f :: * -> *) a s (m :: * -> *) a b.
Functor m =>
a -> Diagram f a s m b -> Diagram f a s m a
fmap :: (a -> b) -> Diagram f a s m a -> Diagram f a s m b
$cfmap :: forall (f :: * -> *) a s (m :: * -> *) a b.
Functor m =>
(a -> b) -> Diagram f a s m a -> Diagram f a s m b
Functor, Functor (Diagram f a s m)
a -> Diagram f a s m a
Functor (Diagram f a s m) =>
(forall a. a -> Diagram f a s m a)
-> (forall a b.
    Diagram f a s m (a -> b) -> Diagram f a s m a -> Diagram f a s m b)
-> (forall a b c.
    (a -> b -> c)
    -> Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m c)
-> (forall a b.
    Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b)
-> (forall a b.
    Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m a)
-> Applicative (Diagram f a s m)
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m a
Diagram f a s m (a -> b) -> Diagram f a s m a -> Diagram f a s m b
(a -> b -> c)
-> Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m c
forall a. a -> Diagram f a s m a
forall a b.
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m a
forall a b.
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b
forall a b.
Diagram f a s m (a -> b) -> Diagram f a s m a -> Diagram f a s m b
forall a b c.
(a -> b -> c)
-> Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (f :: * -> *) a s (m :: * -> *).
Monad m =>
Functor (Diagram f a s m)
forall (f :: * -> *) a s (m :: * -> *) a.
Monad m =>
a -> Diagram f a s m a
forall (f :: * -> *) a s (m :: * -> *) a b.
Monad m =>
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m a
forall (f :: * -> *) a s (m :: * -> *) a b.
Monad m =>
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b
forall (f :: * -> *) a s (m :: * -> *) a b.
Monad m =>
Diagram f a s m (a -> b) -> Diagram f a s m a -> Diagram f a s m b
forall (f :: * -> *) a s (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m c
<* :: Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m a
$c<* :: forall (f :: * -> *) a s (m :: * -> *) a b.
Monad m =>
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m a
*> :: Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b
$c*> :: forall (f :: * -> *) a s (m :: * -> *) a b.
Monad m =>
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b
liftA2 :: (a -> b -> c)
-> Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m c
$cliftA2 :: forall (f :: * -> *) a s (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m c
<*> :: Diagram f a s m (a -> b) -> Diagram f a s m a -> Diagram f a s m b
$c<*> :: forall (f :: * -> *) a s (m :: * -> *) a b.
Monad m =>
Diagram f a s m (a -> b) -> Diagram f a s m a -> Diagram f a s m b
pure :: a -> Diagram f a s m a
$cpure :: forall (f :: * -> *) a s (m :: * -> *) a.
Monad m =>
a -> Diagram f a s m a
$cp1Applicative :: forall (f :: * -> *) a s (m :: * -> *).
Monad m =>
Functor (Diagram f a s m)
Applicative, Applicative (Diagram f a s m)
a -> Diagram f a s m a
Applicative (Diagram f a s m) =>
(forall a b.
 Diagram f a s m a -> (a -> Diagram f a s m b) -> Diagram f a s m b)
-> (forall a b.
    Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b)
-> (forall a. a -> Diagram f a s m a)
-> Monad (Diagram f a s m)
Diagram f a s m a -> (a -> Diagram f a s m b) -> Diagram f a s m b
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b
forall a. a -> Diagram f a s m a
forall a b.
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b
forall a b.
Diagram f a s m a -> (a -> Diagram f a s m b) -> Diagram f a s m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (f :: * -> *) a s (m :: * -> *).
Monad m =>
Applicative (Diagram f a s m)
forall (f :: * -> *) a s (m :: * -> *) a.
Monad m =>
a -> Diagram f a s m a
forall (f :: * -> *) a s (m :: * -> *) a b.
Monad m =>
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b
forall (f :: * -> *) a s (m :: * -> *) a b.
Monad m =>
Diagram f a s m a -> (a -> Diagram f a s m b) -> Diagram f a s m b
return :: a -> Diagram f a s m a
$creturn :: forall (f :: * -> *) a s (m :: * -> *) a.
Monad m =>
a -> Diagram f a s m a
>> :: Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b
$c>> :: forall (f :: * -> *) a s (m :: * -> *) a b.
Monad m =>
Diagram f a s m a -> Diagram f a s m b -> Diagram f a s m b
>>= :: Diagram f a s m a -> (a -> Diagram f a s m b) -> Diagram f a s m b
$c>>= :: forall (f :: * -> *) a s (m :: * -> *) a b.
Monad m =>
Diagram f a s m a -> (a -> Diagram f a s m b) -> Diagram f a s m b
$cp1Monad :: forall (f :: * -> *) a s (m :: * -> *).
Monad m =>
Applicative (Diagram f a s m)
Monad, m a -> Diagram f a s m a
(forall (m :: * -> *) a. Monad m => m a -> Diagram f a s m a)
-> MonadTrans (Diagram f a s)
forall (m :: * -> *) a. Monad m => m a -> Diagram f a s m a
forall (f :: * -> *) a s (m :: * -> *) a.
Monad m =>
m a -> Diagram f a s m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> Diagram f a s m a
$clift :: forall (f :: * -> *) a s (m :: * -> *) a.
Monad m =>
m a -> Diagram f a s m a
MonadTrans)

-- | Extract non-diagrammatic information
runDiagram :: Monad m => (forall s. Diagram f a s m b) -> m b
runDiagram :: (forall s. Diagram f a s m b) -> m b
runDiagram (Diagram d) = StateT
  (Int, HashMap (Free_ f a Any) Int, IntMap (Free_ f a Any)) m b
-> (Int, HashMap (Free_ f a Any) Int, IntMap (Free_ f a Any))
-> m b
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT
  (Int, HashMap (Free_ f a Any) Int, IntMap (Free_ f a Any)) m b
d (0, HashMap (Free_ f a Any) Int
forall k v. HashMap k v
H.empty, IntMap (Free_ f a Any)
forall a. IntMap a
I.empty)

-- | Remove diagrmmatic information from the underlying monad.
-- This could have problematic side-effects and should be used with caution
compress :: Monad m => Diagram f a s m b -> Diagram f a s Identity (m b)
compress :: Diagram f a s m b -> Diagram f a s Identity (m b)
compress = StateT
  (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
  Identity
  (m b)
-> Diagram f a s Identity (m b)
forall (f :: * -> *) a s (m :: * -> *) r.
StateT (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) m r
-> Diagram f a s m r
Diagram (StateT
   (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
   Identity
   (m b)
 -> Diagram f a s Identity (m b))
-> (Diagram f a s m b
    -> StateT
         (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
         Identity
         (m b))
-> Diagram f a s m b
-> Diagram f a s Identity (m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) -> m b)
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
     Identity
     (m b)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (((Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) -> m b)
 -> StateT
      (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
      Identity
      (m b))
-> (Diagram f a s m b
    -> (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) -> m b)
-> Diagram f a s m b
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
     Identity
     (m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) m b
-> (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) -> m b
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) m b
 -> (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) -> m b)
-> (Diagram f a s m b
    -> StateT
         (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) m b)
-> Diagram f a s m b
-> (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Diagram f a s m b
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) m b
forall (f :: * -> *) a s (m :: * -> *) r.
Diagram f a s m r
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) m r
getState

-- Find a node from it's ID
lookup :: Monad m => Int -> Diagram f a s m (f (Free f a s))
lookup :: Int -> Diagram f a s m (f (Free f a s))
lookup i :: Int
i = StateT
  (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
  m
  (f (Free f a s))
-> Diagram f a s m (f (Free f a s))
forall (f :: * -> *) a s (m :: * -> *) r.
StateT (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) m r
-> Diagram f a s m r
Diagram (StateT
   (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
   m
   (f (Free f a s))
 -> Diagram f a s m (f (Free f a s)))
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
     m
     (f (Free f a s))
-> Diagram f a s m (f (Free f a s))
forall a b. (a -> b) -> a -> b
$ do
  (_, _, fs :: IntMap (Free_ f a s)
fs) <- StateT
  (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
  m
  (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
forall s (m :: * -> *). MonadState s m => m s
get
  case Int -> IntMap (Free_ f a s) -> Maybe (Free_ f a s)
forall a. Int -> IntMap a -> Maybe a
I.lookup Int
i IntMap (Free_ f a s)
fs of
    Nothing -> [Char]
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
     m
     (f (Free f a s))
forall a. HasCallStack => [Char] -> a
error "No free with that id!"
    Just f :: Free_ f a s
f -> f (Free f a s)
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
     m
     (f (Free f a s))
forall (m :: * -> *) a. Monad m => a -> m a
return (Free_ f a s -> f (Free f a s)
forall (f :: * -> *) a s. Free_ f a s -> f (Free f a s)
inner Free_ f a s
f)

-- | The Free monad parameterised by it's diagram.
-- Approximately it corresponds to a non-terminal or sub-diagram
data Free (f :: * -> *) a s
  = Pure a
  | ID Int
  deriving (Free f a s -> Free f a s -> Bool
(Free f a s -> Free f a s -> Bool)
-> (Free f a s -> Free f a s -> Bool) -> Eq (Free f a s)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (f :: * -> *) a s. Eq a => Free f a s -> Free f a s -> Bool
/= :: Free f a s -> Free f a s -> Bool
$c/= :: forall (f :: * -> *) a s. Eq a => Free f a s -> Free f a s -> Bool
== :: Free f a s -> Free f a s -> Bool
$c== :: forall (f :: * -> *) a s. Eq a => Free f a s -> Free f a s -> Bool
Eq, Eq (Free f a s)
Eq (Free f a s) =>
(Free f a s -> Free f a s -> Ordering)
-> (Free f a s -> Free f a s -> Bool)
-> (Free f a s -> Free f a s -> Bool)
-> (Free f a s -> Free f a s -> Bool)
-> (Free f a s -> Free f a s -> Bool)
-> (Free f a s -> Free f a s -> Free f a s)
-> (Free f a s -> Free f a s -> Free f a s)
-> Ord (Free f a s)
Free f a s -> Free f a s -> Bool
Free f a s -> Free f a s -> Ordering
Free f a s -> Free f a s -> Free f a s
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (f :: * -> *) a s. Ord a => Eq (Free f a s)
forall (f :: * -> *) a s. Ord a => Free f a s -> Free f a s -> Bool
forall (f :: * -> *) a s.
Ord a =>
Free f a s -> Free f a s -> Ordering
forall (f :: * -> *) a s.
Ord a =>
Free f a s -> Free f a s -> Free f a s
min :: Free f a s -> Free f a s -> Free f a s
$cmin :: forall (f :: * -> *) a s.
Ord a =>
Free f a s -> Free f a s -> Free f a s
max :: Free f a s -> Free f a s -> Free f a s
$cmax :: forall (f :: * -> *) a s.
Ord a =>
Free f a s -> Free f a s -> Free f a s
>= :: Free f a s -> Free f a s -> Bool
$c>= :: forall (f :: * -> *) a s. Ord a => Free f a s -> Free f a s -> Bool
> :: Free f a s -> Free f a s -> Bool
$c> :: forall (f :: * -> *) a s. Ord a => Free f a s -> Free f a s -> Bool
<= :: Free f a s -> Free f a s -> Bool
$c<= :: forall (f :: * -> *) a s. Ord a => Free f a s -> Free f a s -> Bool
< :: Free f a s -> Free f a s -> Bool
$c< :: forall (f :: * -> *) a s. Ord a => Free f a s -> Free f a s -> Bool
compare :: Free f a s -> Free f a s -> Ordering
$ccompare :: forall (f :: * -> *) a s.
Ord a =>
Free f a s -> Free f a s -> Ordering
$cp1Ord :: forall (f :: * -> *) a s. Ord a => Eq (Free f a s)
Ord, (forall x. Free f a s -> Rep (Free f a s) x)
-> (forall x. Rep (Free f a s) x -> Free f a s)
-> Generic (Free f a s)
forall x. Rep (Free f a s) x -> Free f a s
forall x. Free f a s -> Rep (Free f a s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) a s x. Rep (Free f a s) x -> Free f a s
forall (f :: * -> *) a s x. Free f a s -> Rep (Free f a s) x
$cto :: forall (f :: * -> *) a s x. Rep (Free f a s) x -> Free f a s
$cfrom :: forall (f :: * -> *) a s x. Free f a s -> Rep (Free f a s) x
Generic)

newtype Free_ f a s = Free
  { Free_ f a s -> f (Free f a s)
inner :: f (Free f a s)
  }

instance Hashable a => Hashable (Free f a s)

instance (Eq a, Eq1 f) => Eq (Free_ f a s) where
  Free f :: f (Free f a s)
f == :: Free_ f a s -> Free_ f a s -> Bool
== Free g :: f (Free f a s)
g = (Free f a s -> Free f a s -> Bool)
-> f (Free f a s) -> f (Free f a s) -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq Free f a s -> Free f a s -> Bool
forall a. Eq a => a -> a -> Bool
(==) f (Free f a s)
f f (Free f a s)
g

instance (Hashable a, Hashable1 f) => Hashable (Free_ f a s) where
  hashWithSalt :: Int -> Free_ f a s -> Int
hashWithSalt s :: Int
s (Free f :: f (Free f a s)
f) = (Int -> Free f a s -> Int) -> Int -> f (Free f a s) -> Int
forall (t :: * -> *) a.
Hashable1 t =>
(Int -> a -> Int) -> Int -> t a -> Int
liftHashWithSalt Int -> Free f a s -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s f (Free f a s)
f

-- | Analogous to the Free constructor, this fuction wraps another functorial layer.
-- In a graph setting, this corresponds to creating a node from it's offspring structure
free :: (Monad m, Hashable1 f, Hashable a, Eq1 f, Eq a) => f (Free f a s) -> Diagram f a s m (Free f a s)
free :: f (Free f a s) -> Diagram f a s m (Free f a s)
free f :: f (Free f a s)
f = StateT
  (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
  m
  (Free f a s)
-> Diagram f a s m (Free f a s)
forall (f :: * -> *) a s (m :: * -> *) r.
StateT (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) m r
-> Diagram f a s m r
Diagram (StateT
   (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
   m
   (Free f a s)
 -> Diagram f a s m (Free f a s))
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
     m
     (Free f a s)
-> Diagram f a s m (Free f a s)
forall a b. (a -> b) -> a -> b
$ do
  (i :: Int
i, h :: HashMap (Free_ f a s) Int
h, fs :: IntMap (Free_ f a s)
fs) <- StateT
  (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
  m
  (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
forall s (m :: * -> *). MonadState s m => m s
get
  case Free_ f a s -> HashMap (Free_ f a s) Int -> Maybe Int
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup (f (Free f a s) -> Free_ f a s
forall (f :: * -> *) a s. f (Free f a s) -> Free_ f a s
Free f (Free f a s)
f) HashMap (Free_ f a s) Int
h of
    Just j :: Int
j -> Free f a s
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
     m
     (Free f a s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Free f a s
forall (f :: * -> *) a s. Int -> Free f a s
ID Int
j) -- Node sharing
    Nothing -> do
      (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s)) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Free_ f a s
-> Int -> HashMap (Free_ f a s) Int -> HashMap (Free_ f a s) Int
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert (f (Free f a s) -> Free_ f a s
forall (f :: * -> *) a s. f (Free f a s) -> Free_ f a s
Free f (Free f a s)
f) Int
i HashMap (Free_ f a s) Int
h, Int -> Free_ f a s -> IntMap (Free_ f a s) -> IntMap (Free_ f a s)
forall a. Int -> a -> IntMap a -> IntMap a
I.insert Int
i (f (Free f a s) -> Free_ f a s
forall (f :: * -> *) a s. f (Free f a s) -> Free_ f a s
Free f (Free f a s)
f) IntMap (Free_ f a s)
fs)
      Free f a s
-> StateT
     (Int, HashMap (Free_ f a s) Int, IntMap (Free_ f a s))
     m
     (Free f a s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Free f a s
forall (f :: * -> *) a s. Int -> Free f a s
ID Int
i)

-- | Case analysis for 'Free', the first argument is the 'free' continuation, and the second is the 'Pure' case.
{-# INLINE fromFree #-}
fromFree :: Monad m => Free f a s -> (f (Free f a s) -> Diagram f a s m b) -> (a -> Diagram f a s m b) -> Diagram f a s m b
fromFree :: Free f a s
-> (f (Free f a s) -> Diagram f a s m b)
-> (a -> Diagram f a s m b)
-> Diagram f a s m b
fromFree (Pure a :: a
a) _ b :: a -> Diagram f a s m b
b = a -> Diagram f a s m b
b a
a
fromFree (ID i :: Int
i) f :: f (Free f a s) -> Diagram f a s m b
f _ = Int -> Diagram f a s m (f (Free f a s))
forall (m :: * -> *) (f :: * -> *) a s.
Monad m =>
Int -> Diagram f a s m (f (Free f a s))
lookup Int
i Diagram f a s m (f (Free f a s))
-> (f (Free f a s) -> Diagram f a s m b) -> Diagram f a s m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f (Free f a s) -> Diagram f a s m b
f

-- | When @f@ is monadic itself, 'retract' will collapse the recursive structure
retract :: (Monad f, Traversable f) => Free f a s -> Diagram f a s f a
{-# INLINE retract #-}
retract :: Free f a s -> Diagram f a s f a
retract = (f a -> Diagram f a s f a)
-> (a -> Diagram f a s f a) -> Free f a s -> Diagram f a s f a
forall (m :: * -> *) (f :: * -> *) b a s.
(Monad m, Traversable f) =>
(f b -> Diagram f a s m b)
-> (a -> Diagram f a s m b) -> Free f a s -> Diagram f a s m b
fold f a -> Diagram f a s f a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f a -> Diagram f a s f a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f a -> Diagram f a s f a) -> (a -> f a) -> a -> Diagram f a s f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return)

-- | Apply a function to all terminals in a 'Free' sub-diagram
{-# INLINE map #-}
map :: (Hashable1 f, Hashable a, Eq1 f, Eq a, Monad m, Traversable f) => (a -> Diagram f a s m a) -> Free f a s -> Diagram f a s m (Free f a s)
map :: (a -> Diagram f a s m a)
-> Free f a s -> Diagram f a s m (Free f a s)
map f :: a -> Diagram f a s m a
f = (f (Free f a s) -> Diagram f a s m (Free f a s))
-> (a -> Diagram f a s m (Free f a s))
-> Free f a s
-> Diagram f a s m (Free f a s)
forall (m :: * -> *) (f :: * -> *) b a s.
(Monad m, Traversable f) =>
(f b -> Diagram f a s m b)
-> (a -> Diagram f a s m b) -> Free f a s -> Diagram f a s m b
fold f (Free f a s) -> Diagram f a s m (Free f a s)
forall (m :: * -> *) (f :: * -> *) a s.
(Monad m, Hashable1 f, Hashable a, Eq1 f, Eq a) =>
f (Free f a s) -> Diagram f a s m (Free f a s)
free ((a -> Free f a s)
-> Diagram f a s m a -> Diagram f a s m (Free f a s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Free f a s
forall (f :: * -> *) a s. a -> Free f a s
Pure (Diagram f a s m a -> Diagram f a s m (Free f a s))
-> (a -> Diagram f a s m a) -> a -> Diagram f a s m (Free f a s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Diagram f a s m a
f)

-- | Replace a terminal with a non-terminal in a 'Free' sub-diagram
{-# INLINE bind #-}
bind :: (Hashable1 f, Hashable a, Eq1 f, Eq a, Monad m, Traversable f) => Free f a s -> (a -> Diagram f a s m (Free f a s)) -> Diagram f a s m (Free f a s)
bind :: Free f a s
-> (a -> Diagram f a s m (Free f a s))
-> Diagram f a s m (Free f a s)
bind = ((a -> Diagram f a s m (Free f a s))
 -> Free f a s -> Diagram f a s m (Free f a s))
-> Free f a s
-> (a -> Diagram f a s m (Free f a s))
-> Diagram f a s m (Free f a s)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((f (Free f a s) -> Diagram f a s m (Free f a s))
-> (a -> Diagram f a s m (Free f a s))
-> Free f a s
-> Diagram f a s m (Free f a s)
forall (m :: * -> *) (f :: * -> *) b a s.
(Monad m, Traversable f) =>
(f b -> Diagram f a s m b)
-> (a -> Diagram f a s m b) -> Free f a s -> Diagram f a s m b
fold f (Free f a s) -> Diagram f a s m (Free f a s)
forall (m :: * -> *) (f :: * -> *) a s.
(Monad m, Hashable1 f, Hashable a, Eq1 f, Eq a) =>
f (Free f a s) -> Diagram f a s m (Free f a s)
free)

-- | Collapses a 'Free' sub-diagram by instianting the terminals and offpsring structure
{-# INLINE fold #-}
fold :: (Monad m, Traversable f) => (f b -> Diagram f a s m b) -> (a -> Diagram f a s m b) -> Free f a s -> Diagram f a s m b
fold :: (f b -> Diagram f a s m b)
-> (a -> Diagram f a s m b) -> Free f a s -> Diagram f a s m b
fold f :: f b -> Diagram f a s m b
f b :: a -> Diagram f a s m b
b x :: Free f a s
x = Free f a s
-> (f (Free f a s) -> Diagram f a s m b)
-> (a -> Diagram f a s m b)
-> Diagram f a s m b
forall (m :: * -> *) (f :: * -> *) a s b.
Monad m =>
Free f a s
-> (f (Free f a s) -> Diagram f a s m b)
-> (a -> Diagram f a s m b)
-> Diagram f a s m b
fromFree Free f a s
x ((Free f a s -> Diagram f a s m b)
-> f (Free f a s) -> Diagram f a s m (f b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((f b -> Diagram f a s m b)
-> (a -> Diagram f a s m b) -> Free f a s -> Diagram f a s m b
forall (m :: * -> *) (f :: * -> *) b a s.
(Monad m, Traversable f) =>
(f b -> Diagram f a s m b)
-> (a -> Diagram f a s m b) -> Free f a s -> Diagram f a s m b
fold f b -> Diagram f a s m b
f a -> Diagram f a s m b
b) (f (Free f a s) -> Diagram f a s m (f b))
-> (f b -> Diagram f a s m b)
-> f (Free f a s)
-> Diagram f a s m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> f b -> Diagram f a s m b
f) a -> Diagram f a s m b
b