{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Some useful fixpoints of Functors and Bifunctors.
module Bowtie
  ( Base1
  , Recursive1 (..)
  , Corecursive1 (..)
  , cata1
  , cata1M
  , fmapViaBi
  , foldrViaBi
  , traverseViaBi
  , Fix (..)
  , mkFix
  , unMkFix
  , transFix
  , Knot (..)
  , mkKnot
  , unMkKnot
  , transKnot
  , Anno (..)
  , annoUnit
  , annoUnitM
  , annoCounit
  , annoCounitM
  , annoLeft
  , annoLeftM
  , annoRight
  , annoRightM
  , MemoF (..)
  , pattern MemoFP
  , memoFKey
  , memoFVal
  , Memo (..)
  , pattern MemoP
  , mkMemo
  , unMkMemo
  , transMemo
  , memoKey
  , memoVal
  , memoCata
  , memoCataM
  , memoRight
  , memoRightM
  , memoExtend
  , JotF (..)
  , pattern JotFP
  , jotFKey
  , jotFVal
  , Jot (..)
  , pattern JotP
  , mkJot
  , unMkJot
  , annoJot
  , transJot
  , jotKey
  , jotVal
  , jotCata
  , jotCataM
  , jotRight
  , jotRightM
  , jotExtend
  )
where

import Control.Comonad (Comonad (..))
import Control.Exception (Exception)
import Control.Monad ((>=>))
import Control.Monad.Reader (Reader, ReaderT (..), runReader)
import Data.Bifoldable (Bifoldable (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Bitraversable (Bitraversable (..))
import Data.Functor.Apply (Apply (..))
import Data.Functor.Foldable (Base, Corecursive (..), Recursive (..))
import Data.Functor.Identity (Identity (..))
import Data.Kind (Type)
import Data.String (IsString (..))
import Data.Typeable (Typeable)
import Prettyprinter (Pretty (..))

-- | 'Base' for Bifunctors
type family Base1 (f :: Type -> Type) :: Type -> Type -> Type

-- | 'Recursive' for Bifunctors
class (Bifunctor (Base1 f), Functor f) => Recursive1 f where
  project1 :: f a -> Base1 f a (f a)

-- | 'Corecursive' for Bifunctors
class (Bifunctor (Base1 f), Functor f) => Corecursive1 f where
  embed1 :: Base1 f a (f a) -> f a

-- | 'cata' for Bifunctors
cata1 :: (Recursive1 f, Base1 f ~ g) => (g a b -> b) -> f a -> b
cata1 :: forall (f :: * -> *) (g :: * -> * -> *) a b.
(Recursive1 f, Base1 f ~ g) =>
(g a b -> b) -> f a -> b
cata1 g a b -> b
f = f a -> b
go where go :: f a -> b
go = g a b -> b
f (g a b -> b) -> (f a -> g a b) -> f a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a -> b) -> g a (f a) -> g a b
forall b c a. (b -> c) -> g a b -> g a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second f a -> b
go (g a (f a) -> g a b) -> (f a -> g a (f a)) -> f a -> g a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> g a (f a)
f a -> Base1 f a (f a)
forall a. f a -> Base1 f a (f a)
forall (f :: * -> *) a. Recursive1 f => f a -> Base1 f a (f a)
project1

-- | 'cataM' for Bifunctors
cata1M :: (Monad m, Recursive1 f, Base1 f ~ g, Bitraversable g) => (g a b -> m b) -> f a -> m b
cata1M :: forall (m :: * -> *) (f :: * -> *) (g :: * -> * -> *) a b.
(Monad m, Recursive1 f, Base1 f ~ g, Bitraversable g) =>
(g a b -> m b) -> f a -> m b
cata1M g a b -> m b
f = f a -> m b
go where go :: f a -> m b
go = (a -> m a) -> (f a -> m b) -> g a (f a) -> m (g a b)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> g a b -> f (g c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a -> m b
go (g a (f a) -> m (g a b)) -> (f a -> g a (f a)) -> f a -> m (g a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> g a (f a)
f a -> Base1 f a (f a)
forall a. f a -> Base1 f a (f a)
forall (f :: * -> *) a. Recursive1 f => f a -> Base1 f a (f a)
project1 (f a -> m (g a b)) -> (g a b -> m b) -> f a -> m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> g a b -> m b
f

-- | A useful default 'fmap'
fmapViaBi :: (Recursive1 f, Corecursive1 f, Base1 f ~ g) => (a -> b) -> f a -> f b
fmapViaBi :: forall (f :: * -> *) (g :: * -> * -> *) a b.
(Recursive1 f, Corecursive1 f, Base1 f ~ g) =>
(a -> b) -> f a -> f b
fmapViaBi a -> b
f = f a -> f b
go where go :: f a -> f b
go = g b (f b) -> f b
Base1 f b (f b) -> f b
forall a. Base1 f a (f a) -> f a
forall (f :: * -> *) a. Corecursive1 f => Base1 f a (f a) -> f a
embed1 (g b (f b) -> f b) -> (f a -> g b (f b)) -> f a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> (f a -> f b) -> g a (f a) -> g b (f b)
forall a b c d. (a -> b) -> (c -> d) -> g a c -> g b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f f a -> f b
go (g a (f a) -> g b (f b)) -> (f a -> g a (f a)) -> f a -> g b (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> g a (f a)
f a -> Base1 f a (f a)
forall a. f a -> Base1 f a (f a)
forall (f :: * -> *) a. Recursive1 f => f a -> Base1 f a (f a)
project1

-- | A useful default 'foldr'
foldrViaBi :: (Recursive1 f, Base1 f ~ g, Bifoldable g) => (a -> b -> b) -> b -> f a -> b
foldrViaBi :: forall (f :: * -> *) (g :: * -> * -> *) a b.
(Recursive1 f, Base1 f ~ g, Bifoldable g) =>
(a -> b -> b) -> b -> f a -> b
foldrViaBi a -> b -> b
f = (f a -> b -> b) -> b -> f a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip f a -> b -> b
go where go :: f a -> b -> b
go f a
fa b
b = (a -> b -> b) -> (f a -> b -> b) -> b -> g a (f a) -> b
forall a c b. (a -> c -> c) -> (b -> c -> c) -> c -> g a b -> c
forall (p :: * -> * -> *) a c b.
Bifoldable p =>
(a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldr a -> b -> b
f f a -> b -> b
go b
b (f a -> Base1 f a (f a)
forall a. f a -> Base1 f a (f a)
forall (f :: * -> *) a. Recursive1 f => f a -> Base1 f a (f a)
project1 f a
fa)

-- | A useful default 'traverse'
traverseViaBi
  :: (Recursive1 f, Corecursive1 f, Base1 f ~ g, Bitraversable g, Applicative m) => (a -> m b) -> f a -> m (f b)
traverseViaBi :: forall (f :: * -> *) (g :: * -> * -> *) (m :: * -> *) a b.
(Recursive1 f, Corecursive1 f, Base1 f ~ g, Bitraversable g,
 Applicative m) =>
(a -> m b) -> f a -> m (f b)
traverseViaBi a -> m b
f = f a -> m (f b)
go where go :: f a -> m (f b)
go = (g b (f b) -> f b) -> m (g b (f b)) -> m (f b)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g b (f b) -> f b
Base1 f b (f b) -> f b
forall a. Base1 f a (f a) -> f a
forall (f :: * -> *) a. Corecursive1 f => Base1 f a (f a) -> f a
embed1 (m (g b (f b)) -> m (f b))
-> (f a -> m (g b (f b))) -> f a -> m (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m b) -> (f a -> m (f b)) -> g a (f a) -> m (g b (f b))
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> g a b -> f (g c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> m b
f f a -> m (f b)
go (g a (f a) -> m (g b (f b)))
-> (f a -> g a (f a)) -> f a -> m (g b (f b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> g a (f a)
f a -> Base1 f a (f a)
forall a. f a -> Base1 f a (f a)
forall (f :: * -> *) a. Recursive1 f => f a -> Base1 f a (f a)
project1

-- | A basic Functor fixpoint like you'd see anywhere.
type Fix :: (Type -> Type) -> Type
newtype Fix f = Fix {forall (f :: * -> *). Fix f -> f (Fix f)
unFix :: f (Fix f)}

deriving newtype instance (Eq (f (Fix f))) => Eq (Fix f)

deriving newtype instance (Ord (f (Fix f))) => Ord (Fix f)

deriving stock instance (Show (f (Fix f))) => Show (Fix f)

deriving newtype instance (Pretty (f (Fix f))) => Pretty (Fix f)

deriving newtype instance (IsString (f (Fix f))) => IsString (Fix f)

type instance Base (Fix f) = f

instance (Functor f) => Recursive (Fix f) where project :: Fix f -> Base (Fix f) (Fix f)
project = Fix f -> f (Fix f)
Fix f -> Base (Fix f) (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

instance (Functor f) => Corecursive (Fix f) where embed :: Base (Fix f) (Fix f) -> Fix f
embed = f (Fix f) -> Fix f
Base (Fix f) (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix

-- | Pull a recursive structure apart and retie as a 'Fix'.
mkFix :: (Recursive t, Base t ~ f) => t -> Fix f
mkFix :: forall t (f :: * -> *). (Recursive t, Base t ~ f) => t -> Fix f
mkFix = (Base t (Fix f) -> Fix f) -> t -> Fix f
forall t a. Recursive t => (Base t a -> a) -> t -> a
forall a. (Base t a -> a) -> t -> a
cata f (Fix f) -> Fix f
Base t (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix

-- | Go the other way.
unMkFix :: (Corecursive t, Base t ~ f) => Fix f -> t
unMkFix :: forall t (f :: * -> *). (Corecursive t, Base t ~ f) => Fix f -> t
unMkFix = (Base (Fix f) t -> t) -> Fix f -> t
forall t a. Recursive t => (Base t a -> a) -> t -> a
forall a. (Base (Fix f) a -> a) -> Fix f -> a
cata Base t t -> t
Base (Fix f) t -> t
forall t. Corecursive t => Base t t -> t
embed

-- | Transform the base Functor.
transFix :: (Functor f) => (forall x. f x -> g x) -> Fix f -> Fix g
transFix :: forall (f :: * -> *) (g :: * -> *).
Functor f =>
(forall x. f x -> g x) -> Fix f -> Fix g
transFix forall x. f x -> g x
nat = Fix f -> Fix g
go
 where
  go :: Fix f -> Fix g
go = g (Fix g) -> Fix g
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (g (Fix g) -> Fix g) -> (Fix f -> g (Fix g)) -> Fix f -> Fix g
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Fix g) -> g (Fix g)
forall x. f x -> g x
nat (f (Fix g) -> g (Fix g))
-> (Fix f -> f (Fix g)) -> Fix f -> g (Fix g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fix f -> Fix g) -> f (Fix f) -> f (Fix g)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix f -> Fix g
go (f (Fix f) -> f (Fix g))
-> (Fix f -> f (Fix f)) -> Fix f -> f (Fix g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

-- | A fixpoint for a Bifunctor where the second type variable contains
-- the recursive structure.
type Knot :: (Type -> Type -> Type) -> Type -> Type
newtype Knot g a = Knot {forall (g :: * -> * -> *) a. Knot g a -> g a (Knot g a)
unKnot :: g a (Knot g a)}

deriving newtype instance (Eq (g a (Knot g a))) => Eq (Knot g a)

deriving newtype instance (Ord (g a (Knot g a))) => Ord (Knot g a)

deriving stock instance (Show (g a (Knot g a))) => Show (Knot g a)

deriving newtype instance (Pretty (g a (Knot g a))) => Pretty (Knot g a)

deriving newtype instance (IsString (g a (Knot g a))) => IsString (Knot g a)

type instance Base1 (Knot g) = g

instance (Bifunctor g) => Recursive1 (Knot g) where project1 :: forall a. Knot g a -> Base1 (Knot g) a (Knot g a)
project1 = Knot g a -> g a (Knot g a)
Knot g a -> Base1 (Knot g) a (Knot g a)
forall (g :: * -> * -> *) a. Knot g a -> g a (Knot g a)
unKnot

instance (Bifunctor g) => Corecursive1 (Knot g) where embed1 :: forall a. Base1 (Knot g) a (Knot g a) -> Knot g a
embed1 = g a (Knot g a) -> Knot g a
Base1 (Knot g) a (Knot g a) -> Knot g a
forall (g :: * -> * -> *) a. g a (Knot g a) -> Knot g a
Knot

instance (Bifunctor g) => Functor (Knot g) where fmap :: forall a b. (a -> b) -> Knot g a -> Knot g b
fmap = (a -> b) -> Knot g a -> Knot g b
forall (f :: * -> *) (g :: * -> * -> *) a b.
(Recursive1 f, Corecursive1 f, Base1 f ~ g) =>
(a -> b) -> f a -> f b
fmapViaBi

instance (Bifunctor g, Bifoldable g) => Foldable (Knot g) where foldr :: forall a b. (a -> b -> b) -> b -> Knot g a -> b
foldr = (a -> b -> b) -> b -> Knot g a -> b
forall (f :: * -> *) (g :: * -> * -> *) a b.
(Recursive1 f, Base1 f ~ g, Bifoldable g) =>
(a -> b -> b) -> b -> f a -> b
foldrViaBi

instance (Bitraversable g) => Traversable (Knot g) where traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Knot g a -> f (Knot g b)
traverse = (a -> f b) -> Knot g a -> f (Knot g b)
forall (f :: * -> *) (g :: * -> * -> *) (m :: * -> *) a b.
(Recursive1 f, Corecursive1 f, Base1 f ~ g, Bitraversable g,
 Applicative m) =>
(a -> m b) -> f a -> m (f b)
traverseViaBi

-- | Pull a recursive structure apart and retie as a 'Knot'.
mkKnot :: (Recursive1 f, Base1 f ~ g) => f a -> Knot g a
mkKnot :: forall (f :: * -> *) (g :: * -> * -> *) a.
(Recursive1 f, Base1 f ~ g) =>
f a -> Knot g a
mkKnot = (g a (Knot g a) -> Knot g a) -> f a -> Knot g a
forall (f :: * -> *) (g :: * -> * -> *) a b.
(Recursive1 f, Base1 f ~ g) =>
(g a b -> b) -> f a -> b
cata1 g a (Knot g a) -> Knot g a
forall (g :: * -> * -> *) a. g a (Knot g a) -> Knot g a
Knot

-- | Go the other way.
unMkKnot :: (Corecursive1 f, Base1 f ~ g) => Knot g a -> f a
unMkKnot :: forall (f :: * -> *) (g :: * -> * -> *) a.
(Corecursive1 f, Base1 f ~ g) =>
Knot g a -> f a
unMkKnot = (g a (f a) -> f a) -> Knot g a -> f a
forall (f :: * -> *) (g :: * -> * -> *) a b.
(Recursive1 f, Base1 f ~ g) =>
(g a b -> b) -> f a -> b
cata1 g a (f a) -> f a
Base1 f a (f a) -> f a
forall a. Base1 f a (f a) -> f a
forall (f :: * -> *) a. Corecursive1 f => Base1 f a (f a) -> f a
embed1

-- | Transform the base Bifunctor.
transKnot :: (Bifunctor g) => (forall x y. g x y -> h x y) -> Knot g a -> Knot h a
transKnot :: forall (g :: * -> * -> *) (h :: * -> * -> *) a.
Bifunctor g =>
(forall x y. g x y -> h x y) -> Knot g a -> Knot h a
transKnot forall x y. g x y -> h x y
nat = Knot g a -> Knot h a
go
 where
  go :: Knot g a -> Knot h a
go = h a (Knot h a) -> Knot h a
forall (g :: * -> * -> *) a. g a (Knot g a) -> Knot g a
Knot (h a (Knot h a) -> Knot h a)
-> (Knot g a -> h a (Knot h a)) -> Knot g a -> Knot h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g a (Knot h a) -> h a (Knot h a)
forall x y. g x y -> h x y
nat (g a (Knot h a) -> h a (Knot h a))
-> (Knot g a -> g a (Knot h a)) -> Knot g a -> h a (Knot h a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Knot g a -> Knot h a) -> g a (Knot g a) -> g a (Knot h a)
forall b c a. (b -> c) -> g a b -> g a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Knot g a -> Knot h a
go (g a (Knot g a) -> g a (Knot h a))
-> (Knot g a -> g a (Knot g a)) -> Knot g a -> g a (Knot h a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Knot g a -> g a (Knot g a)
forall (g :: * -> * -> *) a. Knot g a -> g a (Knot g a)
unKnot

-- | An "annotation" with associated value.
type Anno :: Type -> Type -> Type
data Anno k v = Anno {forall k v. Anno k v -> k
annoKey :: !k, forall k v. Anno k v -> v
annoVal :: !v}
  deriving stock (Anno k v -> Anno k v -> Bool
(Anno k v -> Anno k v -> Bool)
-> (Anno k v -> Anno k v -> Bool) -> Eq (Anno k v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k v. (Eq k, Eq v) => Anno k v -> Anno k v -> Bool
$c== :: forall k v. (Eq k, Eq v) => Anno k v -> Anno k v -> Bool
== :: Anno k v -> Anno k v -> Bool
$c/= :: forall k v. (Eq k, Eq v) => Anno k v -> Anno k v -> Bool
/= :: Anno k v -> Anno k v -> Bool
Eq, Eq (Anno k v)
Eq (Anno k v) =>
(Anno k v -> Anno k v -> Ordering)
-> (Anno k v -> Anno k v -> Bool)
-> (Anno k v -> Anno k v -> Bool)
-> (Anno k v -> Anno k v -> Bool)
-> (Anno k v -> Anno k v -> Bool)
-> (Anno k v -> Anno k v -> Anno k v)
-> (Anno k v -> Anno k v -> Anno k v)
-> Ord (Anno k v)
Anno k v -> Anno k v -> Bool
Anno k v -> Anno k v -> Ordering
Anno k v -> Anno k v -> Anno k v
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 k v. (Ord k, Ord v) => Eq (Anno k v)
forall k v. (Ord k, Ord v) => Anno k v -> Anno k v -> Bool
forall k v. (Ord k, Ord v) => Anno k v -> Anno k v -> Ordering
forall k v. (Ord k, Ord v) => Anno k v -> Anno k v -> Anno k v
$ccompare :: forall k v. (Ord k, Ord v) => Anno k v -> Anno k v -> Ordering
compare :: Anno k v -> Anno k v -> Ordering
$c< :: forall k v. (Ord k, Ord v) => Anno k v -> Anno k v -> Bool
< :: Anno k v -> Anno k v -> Bool
$c<= :: forall k v. (Ord k, Ord v) => Anno k v -> Anno k v -> Bool
<= :: Anno k v -> Anno k v -> Bool
$c> :: forall k v. (Ord k, Ord v) => Anno k v -> Anno k v -> Bool
> :: Anno k v -> Anno k v -> Bool
$c>= :: forall k v. (Ord k, Ord v) => Anno k v -> Anno k v -> Bool
>= :: Anno k v -> Anno k v -> Bool
$cmax :: forall k v. (Ord k, Ord v) => Anno k v -> Anno k v -> Anno k v
max :: Anno k v -> Anno k v -> Anno k v
$cmin :: forall k v. (Ord k, Ord v) => Anno k v -> Anno k v -> Anno k v
min :: Anno k v -> Anno k v -> Anno k v
Ord, Int -> Anno k v -> ShowS
[Anno k v] -> ShowS
Anno k v -> String
(Int -> Anno k v -> ShowS)
-> (Anno k v -> String) -> ([Anno k v] -> ShowS) -> Show (Anno k v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k v. (Show k, Show v) => Int -> Anno k v -> ShowS
forall k v. (Show k, Show v) => [Anno k v] -> ShowS
forall k v. (Show k, Show v) => Anno k v -> String
$cshowsPrec :: forall k v. (Show k, Show v) => Int -> Anno k v -> ShowS
showsPrec :: Int -> Anno k v -> ShowS
$cshow :: forall k v. (Show k, Show v) => Anno k v -> String
show :: Anno k v -> String
$cshowList :: forall k v. (Show k, Show v) => [Anno k v] -> ShowS
showList :: [Anno k v] -> ShowS
Show, (forall a b. (a -> b) -> Anno k a -> Anno k b)
-> (forall a b. a -> Anno k b -> Anno k a) -> Functor (Anno k)
forall a b. a -> Anno k b -> Anno k a
forall a b. (a -> b) -> Anno k a -> Anno k b
forall k a b. a -> Anno k b -> Anno k a
forall k a b. (a -> b) -> Anno k a -> Anno k b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall k a b. (a -> b) -> Anno k a -> Anno k b
fmap :: forall a b. (a -> b) -> Anno k a -> Anno k b
$c<$ :: forall k a b. a -> Anno k b -> Anno k a
<$ :: forall a b. a -> Anno k b -> Anno k a
Functor, (forall m. Monoid m => Anno k m -> m)
-> (forall m a. Monoid m => (a -> m) -> Anno k a -> m)
-> (forall m a. Monoid m => (a -> m) -> Anno k a -> m)
-> (forall a b. (a -> b -> b) -> b -> Anno k a -> b)
-> (forall a b. (a -> b -> b) -> b -> Anno k a -> b)
-> (forall b a. (b -> a -> b) -> b -> Anno k a -> b)
-> (forall b a. (b -> a -> b) -> b -> Anno k a -> b)
-> (forall a. (a -> a -> a) -> Anno k a -> a)
-> (forall a. (a -> a -> a) -> Anno k a -> a)
-> (forall a. Anno k a -> [a])
-> (forall a. Anno k a -> Bool)
-> (forall a. Anno k a -> Int)
-> (forall a. Eq a => a -> Anno k a -> Bool)
-> (forall a. Ord a => Anno k a -> a)
-> (forall a. Ord a => Anno k a -> a)
-> (forall a. Num a => Anno k a -> a)
-> (forall a. Num a => Anno k a -> a)
-> Foldable (Anno k)
forall a. Eq a => a -> Anno k a -> Bool
forall a. Num a => Anno k a -> a
forall a. Ord a => Anno k a -> a
forall m. Monoid m => Anno k m -> m
forall a. Anno k a -> Bool
forall a. Anno k a -> Int
forall a. Anno k a -> [a]
forall a. (a -> a -> a) -> Anno k a -> a
forall k a. Eq a => a -> Anno k a -> Bool
forall k a. Num a => Anno k a -> a
forall k a. Ord a => Anno k a -> a
forall m a. Monoid m => (a -> m) -> Anno k a -> m
forall k m. Monoid m => Anno k m -> m
forall k a. Anno k a -> Bool
forall k a. Anno k a -> Int
forall k a. Anno k a -> [a]
forall b a. (b -> a -> b) -> b -> Anno k a -> b
forall a b. (a -> b -> b) -> b -> Anno k a -> b
forall k a. (a -> a -> a) -> Anno k a -> a
forall k m a. Monoid m => (a -> m) -> Anno k a -> m
forall k b a. (b -> a -> b) -> b -> Anno k a -> b
forall k a b. (a -> b -> b) -> b -> Anno k a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall k m. Monoid m => Anno k m -> m
fold :: forall m. Monoid m => Anno k m -> m
$cfoldMap :: forall k m a. Monoid m => (a -> m) -> Anno k a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Anno k a -> m
$cfoldMap' :: forall k m a. Monoid m => (a -> m) -> Anno k a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Anno k a -> m
$cfoldr :: forall k a b. (a -> b -> b) -> b -> Anno k a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Anno k a -> b
$cfoldr' :: forall k a b. (a -> b -> b) -> b -> Anno k a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Anno k a -> b
$cfoldl :: forall k b a. (b -> a -> b) -> b -> Anno k a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Anno k a -> b
$cfoldl' :: forall k b a. (b -> a -> b) -> b -> Anno k a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Anno k a -> b
$cfoldr1 :: forall k a. (a -> a -> a) -> Anno k a -> a
foldr1 :: forall a. (a -> a -> a) -> Anno k a -> a
$cfoldl1 :: forall k a. (a -> a -> a) -> Anno k a -> a
foldl1 :: forall a. (a -> a -> a) -> Anno k a -> a
$ctoList :: forall k a. Anno k a -> [a]
toList :: forall a. Anno k a -> [a]
$cnull :: forall k a. Anno k a -> Bool
null :: forall a. Anno k a -> Bool
$clength :: forall k a. Anno k a -> Int
length :: forall a. Anno k a -> Int
$celem :: forall k a. Eq a => a -> Anno k a -> Bool
elem :: forall a. Eq a => a -> Anno k a -> Bool
$cmaximum :: forall k a. Ord a => Anno k a -> a
maximum :: forall a. Ord a => Anno k a -> a
$cminimum :: forall k a. Ord a => Anno k a -> a
minimum :: forall a. Ord a => Anno k a -> a
$csum :: forall k a. Num a => Anno k a -> a
sum :: forall a. Num a => Anno k a -> a
$cproduct :: forall k a. Num a => Anno k a -> a
product :: forall a. Num a => Anno k a -> a
Foldable, Functor (Anno k)
Foldable (Anno k)
(Functor (Anno k), Foldable (Anno k)) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Anno k a -> f (Anno k b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Anno k (f a) -> f (Anno k a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Anno k a -> m (Anno k b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Anno k (m a) -> m (Anno k a))
-> Traversable (Anno k)
forall k. Functor (Anno k)
forall k. Foldable (Anno k)
forall k (m :: * -> *) a. Monad m => Anno k (m a) -> m (Anno k a)
forall k (f :: * -> *) a.
Applicative f =>
Anno k (f a) -> f (Anno k a)
forall k (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Anno k a -> m (Anno k b)
forall k (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Anno k a -> f (Anno k b)
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Anno k (m a) -> m (Anno k a)
forall (f :: * -> *) a.
Applicative f =>
Anno k (f a) -> f (Anno k a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Anno k a -> m (Anno k b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Anno k a -> f (Anno k b)
$ctraverse :: forall k (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Anno k a -> f (Anno k b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Anno k a -> f (Anno k b)
$csequenceA :: forall k (f :: * -> *) a.
Applicative f =>
Anno k (f a) -> f (Anno k a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Anno k (f a) -> f (Anno k a)
$cmapM :: forall k (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Anno k a -> m (Anno k b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Anno k a -> m (Anno k b)
$csequence :: forall k (m :: * -> *) a. Monad m => Anno k (m a) -> m (Anno k a)
sequence :: forall (m :: * -> *) a. Monad m => Anno k (m a) -> m (Anno k a)
Traversable)

instance Bifunctor Anno where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> Anno a c -> Anno b d
bimap a -> b
f c -> d
g (Anno a
k c
v) = b -> d -> Anno b d
forall k v. k -> v -> Anno k v
Anno (a -> b
f a
k) (c -> d
g c
v)

instance Bifoldable Anno where
  bifoldr :: forall a c b. (a -> c -> c) -> (b -> c -> c) -> c -> Anno a b -> c
bifoldr a -> c -> c
f b -> c -> c
g c
z (Anno a
k b
v) = a -> c -> c
f a
k (b -> c -> c
g b
v c
z)

instance Bitraversable Anno where
  bitraverse :: forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Anno a b -> f (Anno c d)
bitraverse a -> f c
f b -> f d
g (Anno a
k b
v) = (c -> d -> Anno c d) -> f c -> f d -> f (Anno c d)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 c -> d -> Anno c d
forall k v. k -> v -> Anno k v
Anno (a -> f c
f a
k) (b -> f d
g b
v)

instance (Semigroup k) => Apply (Anno k) where
  liftF2 :: forall a b c. (a -> b -> c) -> Anno k a -> Anno k b -> Anno k c
liftF2 a -> b -> c
f (Anno k
k1 a
v1) (Anno k
k2 b
v2) = k -> c -> Anno k c
forall k v. k -> v -> Anno k v
Anno (k
k1 k -> k -> k
forall a. Semigroup a => a -> a -> a
<> k
k2) (a -> b -> c
f a
v1 b
v2)

instance (Monoid k) => Applicative (Anno k) where
  pure :: forall a. a -> Anno k a
pure = k -> a -> Anno k a
forall k v. k -> v -> Anno k v
Anno k
forall a. Monoid a => a
mempty
  liftA2 :: forall a b c. (a -> b -> c) -> Anno k a -> Anno k b -> Anno k c
liftA2 = (a -> b -> c) -> Anno k a -> Anno k b -> Anno k c
forall a b c. (a -> b -> c) -> Anno k a -> Anno k b -> Anno k c
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2

instance Comonad (Anno k) where
  extract :: forall a. Anno k a -> a
extract (Anno k
_ a
v) = a
v
  duplicate :: forall a. Anno k a -> Anno k (Anno k a)
duplicate an :: Anno k a
an@(Anno k
k a
_) = k -> Anno k a -> Anno k (Anno k a)
forall k v. k -> v -> Anno k v
Anno k
k Anno k a
an
  extend :: forall a b. (Anno k a -> b) -> Anno k a -> Anno k b
extend Anno k a -> b
f an :: Anno k a
an@(Anno k
k a
_) = k -> b -> Anno k b
forall k v. k -> v -> Anno k v
Anno k
k (Anno k a -> b
f Anno k a
an)

instance (Pretty v) => Pretty (Anno k v) where
  pretty :: forall ann. Anno k v -> Doc ann
pretty = v -> Doc ann
forall ann. v -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (v -> Doc ann) -> (Anno k v -> v) -> Anno k v -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anno k v -> v
forall k v. Anno k v -> v
annoVal

instance (Monoid k, IsString v) => IsString (Anno k v) where
  fromString :: String -> Anno k v
fromString = k -> v -> Anno k v
forall k v. k -> v -> Anno k v
Anno k
forall a. Monoid a => a
mempty (v -> Anno k v) -> (String -> v) -> String -> Anno k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> v
forall a. IsString a => String -> a
fromString

instance (Show k, Typeable k, Exception v) => Exception (Anno k v)

-- | 'unit' from 'Adjunction'
annoUnit :: v -> Reader k (Anno k v)
annoUnit :: forall v k. v -> Reader k (Anno k v)
annoUnit v
v = (k -> Identity (Anno k v)) -> ReaderT k Identity (Anno k v)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (Anno k v -> Identity (Anno k v)
forall a. a -> Identity a
Identity (Anno k v -> Identity (Anno k v))
-> (k -> Anno k v) -> k -> Identity (Anno k v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> v -> Anno k v
forall k v. k -> v -> Anno k v
`Anno` v
v))

annoUnitM :: (Applicative m) => v -> ReaderT k m (Anno k v)
annoUnitM :: forall (m :: * -> *) v k.
Applicative m =>
v -> ReaderT k m (Anno k v)
annoUnitM v
v = (k -> m (Anno k v)) -> ReaderT k m (Anno k v)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (Anno k v -> m (Anno k v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anno k v -> m (Anno k v)) -> (k -> Anno k v) -> k -> m (Anno k v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> v -> Anno k v
forall k v. k -> v -> Anno k v
`Anno` v
v))

-- | 'counit' from 'Adjunction'
annoCounit :: Anno k (Reader k v) -> v
annoCounit :: forall k v. Anno k (Reader k v) -> v
annoCounit (Anno k
k Reader k v
m) = Reader k v -> k -> v
forall r a. Reader r a -> r -> a
runReader Reader k v
m k
k

annoCounitM :: Anno k (ReaderT k m v) -> m v
annoCounitM :: forall k (m :: * -> *) v. Anno k (ReaderT k m v) -> m v
annoCounitM (Anno k
k ReaderT k m v
m) = ReaderT k m v -> k -> m v
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT k m v
m k
k

-- | 'leftAdjunct' from 'Adjunction'
annoLeft :: (Anno k v -> x) -> v -> Reader k x
annoLeft :: forall k v x. (Anno k v -> x) -> v -> Reader k x
annoLeft Anno k v -> x
f v
v = (k -> Identity x) -> ReaderT k Identity x
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (x -> Identity x
forall a. a -> Identity a
Identity (x -> Identity x) -> (k -> x) -> k -> Identity x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anno k v -> x
f (Anno k v -> x) -> (k -> Anno k v) -> k -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> v -> Anno k v
forall k v. k -> v -> Anno k v
`Anno` v
v))

annoLeftM :: (Anno k v -> m x) -> v -> ReaderT k m x
annoLeftM :: forall k v (m :: * -> *) x. (Anno k v -> m x) -> v -> ReaderT k m x
annoLeftM Anno k v -> m x
f v
v = (k -> m x) -> ReaderT k m x
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (Anno k v -> m x
f (Anno k v -> m x) -> (k -> Anno k v) -> k -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> v -> Anno k v
forall k v. k -> v -> Anno k v
`Anno` v
v))

-- | 'rightAdjunct' from 'Adjunction'
annoRight :: (v -> Reader k x) -> Anno k v -> x
annoRight :: forall v k x. (v -> Reader k x) -> Anno k v -> x
annoRight v -> Reader k x
f (Anno k
k v
v) = Reader k x -> k -> x
forall r a. Reader r a -> r -> a
runReader (v -> Reader k x
f v
v) k
k

annoRightM :: (v -> ReaderT k m x) -> Anno k v -> m x
annoRightM :: forall v k (m :: * -> *) x. (v -> ReaderT k m x) -> Anno k v -> m x
annoRightM v -> ReaderT k m x
f (Anno k
k v
v) = ReaderT k m x -> k -> m x
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (v -> ReaderT k m x
f v
v) k
k

-- | The base functor for a 'Memo'
newtype MemoF f k r = MemoF {forall {k} (f :: k -> *) k (r :: k). MemoF f k r -> Anno k (f r)
unMemoF :: Anno k (f r)}
  deriving stock (Int -> MemoF f k r -> ShowS
[MemoF f k r] -> ShowS
MemoF f k r -> String
(Int -> MemoF f k r -> ShowS)
-> (MemoF f k r -> String)
-> ([MemoF f k r] -> ShowS)
-> Show (MemoF f k r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (f :: k -> *) k (r :: k).
(Show k, Show (f r)) =>
Int -> MemoF f k r -> ShowS
forall k (f :: k -> *) k (r :: k).
(Show k, Show (f r)) =>
[MemoF f k r] -> ShowS
forall k (f :: k -> *) k (r :: k).
(Show k, Show (f r)) =>
MemoF f k r -> String
$cshowsPrec :: forall k (f :: k -> *) k (r :: k).
(Show k, Show (f r)) =>
Int -> MemoF f k r -> ShowS
showsPrec :: Int -> MemoF f k r -> ShowS
$cshow :: forall k (f :: k -> *) k (r :: k).
(Show k, Show (f r)) =>
MemoF f k r -> String
show :: MemoF f k r -> String
$cshowList :: forall k (f :: k -> *) k (r :: k).
(Show k, Show (f r)) =>
[MemoF f k r] -> ShowS
showList :: [MemoF f k r] -> ShowS
Show, (forall a b. (a -> b) -> MemoF f k a -> MemoF f k b)
-> (forall a b. a -> MemoF f k b -> MemoF f k a)
-> Functor (MemoF f k)
forall a b. a -> MemoF f k b -> MemoF f k a
forall a b. (a -> b) -> MemoF f k a -> MemoF f k b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (f :: * -> *) k a b.
Functor f =>
a -> MemoF f k b -> MemoF f k a
forall (f :: * -> *) k a b.
Functor f =>
(a -> b) -> MemoF f k a -> MemoF f k b
$cfmap :: forall (f :: * -> *) k a b.
Functor f =>
(a -> b) -> MemoF f k a -> MemoF f k b
fmap :: forall a b. (a -> b) -> MemoF f k a -> MemoF f k b
$c<$ :: forall (f :: * -> *) k a b.
Functor f =>
a -> MemoF f k b -> MemoF f k a
<$ :: forall a b. a -> MemoF f k b -> MemoF f k a
Functor)
  deriving newtype (MemoF f k r -> MemoF f k r -> Bool
(MemoF f k r -> MemoF f k r -> Bool)
-> (MemoF f k r -> MemoF f k r -> Bool) -> Eq (MemoF f k r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (f :: k -> *) k (r :: k).
(Eq k, Eq (f r)) =>
MemoF f k r -> MemoF f k r -> Bool
$c== :: forall k (f :: k -> *) k (r :: k).
(Eq k, Eq (f r)) =>
MemoF f k r -> MemoF f k r -> Bool
== :: MemoF f k r -> MemoF f k r -> Bool
$c/= :: forall k (f :: k -> *) k (r :: k).
(Eq k, Eq (f r)) =>
MemoF f k r -> MemoF f k r -> Bool
/= :: MemoF f k r -> MemoF f k r -> Bool
Eq, Eq (MemoF f k r)
Eq (MemoF f k r) =>
(MemoF f k r -> MemoF f k r -> Ordering)
-> (MemoF f k r -> MemoF f k r -> Bool)
-> (MemoF f k r -> MemoF f k r -> Bool)
-> (MemoF f k r -> MemoF f k r -> Bool)
-> (MemoF f k r -> MemoF f k r -> Bool)
-> (MemoF f k r -> MemoF f k r -> MemoF f k r)
-> (MemoF f k r -> MemoF f k r -> MemoF f k r)
-> Ord (MemoF f k r)
MemoF f k r -> MemoF f k r -> Bool
MemoF f k r -> MemoF f k r -> Ordering
MemoF f k r -> MemoF f k r -> MemoF f k r
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 k (f :: k -> *) k (r :: k).
(Ord k, Ord (f r)) =>
Eq (MemoF f k r)
forall k (f :: k -> *) k (r :: k).
(Ord k, Ord (f r)) =>
MemoF f k r -> MemoF f k r -> Bool
forall k (f :: k -> *) k (r :: k).
(Ord k, Ord (f r)) =>
MemoF f k r -> MemoF f k r -> Ordering
forall k (f :: k -> *) k (r :: k).
(Ord k, Ord (f r)) =>
MemoF f k r -> MemoF f k r -> MemoF f k r
$ccompare :: forall k (f :: k -> *) k (r :: k).
(Ord k, Ord (f r)) =>
MemoF f k r -> MemoF f k r -> Ordering
compare :: MemoF f k r -> MemoF f k r -> Ordering
$c< :: forall k (f :: k -> *) k (r :: k).
(Ord k, Ord (f r)) =>
MemoF f k r -> MemoF f k r -> Bool
< :: MemoF f k r -> MemoF f k r -> Bool
$c<= :: forall k (f :: k -> *) k (r :: k).
(Ord k, Ord (f r)) =>
MemoF f k r -> MemoF f k r -> Bool
<= :: MemoF f k r -> MemoF f k r -> Bool
$c> :: forall k (f :: k -> *) k (r :: k).
(Ord k, Ord (f r)) =>
MemoF f k r -> MemoF f k r -> Bool
> :: MemoF f k r -> MemoF f k r -> Bool
$c>= :: forall k (f :: k -> *) k (r :: k).
(Ord k, Ord (f r)) =>
MemoF f k r -> MemoF f k r -> Bool
>= :: MemoF f k r -> MemoF f k r -> Bool
$cmax :: forall k (f :: k -> *) k (r :: k).
(Ord k, Ord (f r)) =>
MemoF f k r -> MemoF f k r -> MemoF f k r
max :: MemoF f k r -> MemoF f k r -> MemoF f k r
$cmin :: forall k (f :: k -> *) k (r :: k).
(Ord k, Ord (f r)) =>
MemoF f k r -> MemoF f k r -> MemoF f k r
min :: MemoF f k r -> MemoF f k r -> MemoF f k r
Ord)

pattern MemoFP :: k -> f r -> MemoF f k r
pattern $mMemoFP :: forall {r} {k1} {k2} {f :: k1 -> *} {r :: k1}.
MemoF f k2 r -> (k2 -> f r -> r) -> ((# #) -> r) -> r
$bMemoFP :: forall {k1} k2 (f :: k1 -> *) (r :: k1). k2 -> f r -> MemoF f k2 r
MemoFP k v = MemoF (Anno k v)

{-# COMPLETE MemoFP #-}

deriving newtype instance (Monoid k, IsString (f r)) => IsString (MemoF f k r)

deriving newtype instance (Pretty (f r)) => Pretty (MemoF f k r)

instance (Apply f, Semigroup k) => Apply (MemoF f k) where
  liftF2 :: forall a b c.
(a -> b -> c) -> MemoF f k a -> MemoF f k b -> MemoF f k c
liftF2 a -> b -> c
f (MemoF (Anno k
k1 f a
v1)) (MemoF (Anno k
k2 f b
v2)) = Anno k (f c) -> MemoF f k c
forall {k} (f :: k -> *) k (r :: k). Anno k (f r) -> MemoF f k r
MemoF (k -> f c -> Anno k (f c)
forall k v. k -> v -> Anno k v
Anno (k
k1 k -> k -> k
forall a. Semigroup a => a -> a -> a
<> k
k2) ((a -> b -> c) -> f a -> f b -> f c
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2 a -> b -> c
f f a
v1 f b
v2))

instance (Applicative f, Monoid k) => Applicative (MemoF f k) where
  pure :: forall a. a -> MemoF f k a
pure = Anno k (f a) -> MemoF f k a
forall {k} (f :: k -> *) k (r :: k). Anno k (f r) -> MemoF f k r
MemoF (Anno k (f a) -> MemoF f k a)
-> (a -> Anno k (f a)) -> a -> MemoF f k a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> f a -> Anno k (f a)
forall k v. k -> v -> Anno k v
Anno k
forall a. Monoid a => a
mempty (f a -> Anno k (f a)) -> (a -> f a) -> a -> Anno k (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  liftA2 :: forall a b c.
(a -> b -> c) -> MemoF f k a -> MemoF f k b -> MemoF f k c
liftA2 a -> b -> c
f (MemoF (Anno k
k1 f a
v1)) (MemoF (Anno k
k2 f b
v2)) = Anno k (f c) -> MemoF f k c
forall {k} (f :: k -> *) k (r :: k). Anno k (f r) -> MemoF f k r
MemoF (k -> f c -> Anno k (f c)
forall k v. k -> v -> Anno k v
Anno (k
k1 k -> k -> k
forall a. Semigroup a => a -> a -> a
<> k
k2) ((a -> b -> c) -> f a -> f b -> f c
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f f a
v1 f b
v2))

memoFKey :: MemoF f k r -> k
memoFKey :: forall {k} (f :: k -> *) k (r :: k). MemoF f k r -> k
memoFKey (MemoFP k
k f r
_) = k
k

memoFVal :: MemoF f k r -> f r
memoFVal :: forall {k} (f :: k -> *) k (r :: k). MemoF f k r -> f r
memoFVal (MemoFP k
_ f r
v) = f r
v

-- | An annotated 'Fix'
type Memo :: (Type -> Type) -> Type -> Type
newtype Memo f k = Memo {forall (f :: * -> *) k. Memo f k -> MemoF f k (Memo f k)
unMemo :: MemoF f k (Memo f k)}

pattern MemoP :: k -> f (Memo f k) -> Memo f k
pattern $mMemoP :: forall {r} {k} {f :: * -> *}.
Memo f k -> (k -> f (Memo f k) -> r) -> ((# #) -> r) -> r
$bMemoP :: forall k (f :: * -> *). k -> f (Memo f k) -> Memo f k
MemoP k v = Memo (MemoF (Anno k v))

{-# COMPLETE MemoP #-}

deriving newtype instance (Eq k, Eq (f (Memo f k))) => Eq (Memo f k)

deriving newtype instance (Ord k, Ord (f (Memo f k))) => Ord (Memo f k)

deriving stock instance (Show k, Show (f (Memo f k))) => Show (Memo f k)

deriving newtype instance (Monoid k, IsString (f (Memo f k))) => IsString (Memo f k)

deriving newtype instance (Pretty (f (Memo f k))) => Pretty (Memo f k)

instance (Functor f) => Functor (Memo f) where
  fmap :: forall a b. (a -> b) -> Memo f a -> Memo f b
fmap a -> b
f = Memo f a -> Memo f b
go where go :: Memo f a -> Memo f b
go (MemoP a
k f (Memo f a)
v) = b -> f (Memo f b) -> Memo f b
forall k (f :: * -> *). k -> f (Memo f k) -> Memo f k
MemoP (a -> b
f a
k) ((Memo f a -> Memo f b) -> f (Memo f a) -> f (Memo f b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Memo f a -> Memo f b
go f (Memo f a)
v)

instance (Foldable f) => Foldable (Memo f) where
  foldr :: forall a b. (a -> b -> b) -> b -> Memo f a -> b
foldr a -> b -> b
f = (Memo f a -> b -> b) -> b -> Memo f a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Memo f a -> b -> b
go where go :: Memo f a -> b -> b
go (MemoP a
k f (Memo f a)
v) b
z = (Memo f a -> b -> b) -> b -> f (Memo f a) -> b
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Memo f a -> b -> b
go (a -> b -> b
f a
k b
z) f (Memo f a)
v

instance (Traversable f) => Traversable (Memo f) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Memo f a -> f (Memo f b)
traverse a -> f b
f = Memo f a -> f (Memo f b)
go where go :: Memo f a -> f (Memo f b)
go (MemoP a
k f (Memo f a)
v) = (b -> f (Memo f b) -> Memo f b)
-> f b -> f (f (Memo f b)) -> f (Memo f b)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> f (Memo f b) -> Memo f b
forall k (f :: * -> *). k -> f (Memo f k) -> Memo f k
MemoP (a -> f b
f a
k) ((Memo f a -> f (Memo f b)) -> f (Memo f a) -> f (f (Memo f b))
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) -> f a -> f (f b)
traverse Memo f a -> f (Memo f b)
go f (Memo f a)
v)

type instance Base (Memo f k) = MemoF f k

instance (Functor f) => Recursive (Memo f k) where project :: Memo f k -> Base (Memo f k) (Memo f k)
project = Memo f k -> Base (Memo f k) (Memo f k)
Memo f k -> MemoF f k (Memo f k)
forall (f :: * -> *) k. Memo f k -> MemoF f k (Memo f k)
unMemo

instance (Functor f) => Corecursive (Memo f k) where embed :: Base (Memo f k) (Memo f k) -> Memo f k
embed = Base (Memo f k) (Memo f k) -> Memo f k
MemoF f k (Memo f k) -> Memo f k
forall (f :: * -> *) k. MemoF f k (Memo f k) -> Memo f k
Memo

-- | Pull a recursive structure apart and retie as a 'Memo', using the given
-- function to calculate a key for every level.
mkMemo :: (Recursive t, Base t ~ f) => (f k -> k) -> t -> Memo f k
mkMemo :: forall t (f :: * -> *) k.
(Recursive t, Base t ~ f) =>
(f k -> k) -> t -> Memo f k
mkMemo f k -> k
f = (Base t (Memo f k) -> Memo f k) -> t -> Memo f k
forall t a. Recursive t => (Base t a -> a) -> t -> a
forall a. (Base t a -> a) -> t -> a
cata (\Base t (Memo f k)
v -> k -> f (Memo f k) -> Memo f k
forall k (f :: * -> *). k -> f (Memo f k) -> Memo f k
MemoP (f k -> k
f ((Memo f k -> k) -> f (Memo f k) -> f k
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Memo f k -> k
forall (f :: * -> *) k. Memo f k -> k
memoKey f (Memo f k)
Base t (Memo f k)
v)) f (Memo f k)
Base t (Memo f k)
v)

-- | Forget keys at every level and convert back to a plain structure.
unMkMemo :: (Corecursive t, Base t ~ f) => Memo f k -> t
unMkMemo :: forall t (f :: * -> *) k.
(Corecursive t, Base t ~ f) =>
Memo f k -> t
unMkMemo (MemoP k
_ f (Memo f k)
v) = Base t t -> t
forall t. Corecursive t => Base t t -> t
embed ((Memo f k -> t) -> f (Memo f k) -> f t
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Memo f k -> t
forall t (f :: * -> *) k.
(Corecursive t, Base t ~ f) =>
Memo f k -> t
unMkMemo f (Memo f k)
v)

-- | Transform the base functor.
transMemo :: (Functor f) => (forall x. f x -> g x) -> Memo f k -> Memo g k
transMemo :: forall (f :: * -> *) (g :: * -> *) k.
Functor f =>
(forall x. f x -> g x) -> Memo f k -> Memo g k
transMemo forall x. f x -> g x
nat = Memo f k -> Memo g k
go
 where
  go :: Memo f k -> Memo g k
go (MemoP k
k f (Memo f k)
v) = k -> g (Memo g k) -> Memo g k
forall k (f :: * -> *). k -> f (Memo f k) -> Memo f k
MemoP k
k (f (Memo g k) -> g (Memo g k)
forall x. f x -> g x
nat ((Memo f k -> Memo g k) -> f (Memo f k) -> f (Memo g k)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Memo f k -> Memo g k
go f (Memo f k)
v))

memoKey :: Memo f k -> k
memoKey :: forall (f :: * -> *) k. Memo f k -> k
memoKey (MemoP k
k f (Memo f k)
_) = k
k

memoVal :: Memo f k -> f (Memo f k)
memoVal :: forall (f :: * -> *) k. Memo f k -> f (Memo f k)
memoVal (MemoP k
_ f (Memo f k)
v) = f (Memo f k)
v

-- | 'cata' but nicer
memoCata :: (Functor f) => (f x -> Reader k x) -> Memo f k -> x
memoCata :: forall (f :: * -> *) x k.
Functor f =>
(f x -> Reader k x) -> Memo f k -> x
memoCata f x -> Reader k x
f = Memo f k -> x
go
 where
  go :: Memo f k -> x
go (MemoP k
k f (Memo f k)
v) = Reader k x -> k -> x
forall r a. Reader r a -> r -> a
runReader (f x -> Reader k x
f ((Memo f k -> x) -> f (Memo f k) -> f x
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Memo f k -> x
go f (Memo f k)
v)) k
k

-- | 'cataM' but nicer
memoCataM :: (Monad m, Traversable f) => (f x -> ReaderT k m x) -> Memo f k -> m x
memoCataM :: forall (m :: * -> *) (f :: * -> *) x k.
(Monad m, Traversable f) =>
(f x -> ReaderT k m x) -> Memo f k -> m x
memoCataM f x -> ReaderT k m x
f = Memo f k -> m x
go
 where
  go :: Memo f k -> m x
go (MemoP k
k f (Memo f k)
v) = (Memo f k -> m x) -> f (Memo f k) -> m (f x)
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) -> f a -> f (f b)
traverse Memo f k -> m x
go f (Memo f k)
v m (f x) -> (f x -> m x) -> m x
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \f x
x -> ReaderT k m x -> k -> m x
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (f x -> ReaderT k m x
f f x
x) k
k

-- | Peek at the top value like 'annoRight'
memoRight :: (f (Memo f k) -> Reader k x) -> Memo f k -> x
memoRight :: forall (f :: * -> *) k x.
(f (Memo f k) -> Reader k x) -> Memo f k -> x
memoRight f (Memo f k) -> Reader k x
f = (f (Memo f k) -> Reader k x) -> Anno k (f (Memo f k)) -> x
forall v k x. (v -> Reader k x) -> Anno k v -> x
annoRight f (Memo f k) -> Reader k x
f (Anno k (f (Memo f k)) -> x)
-> (Memo f k -> Anno k (f (Memo f k))) -> Memo f k -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoF f k (Memo f k) -> Anno k (f (Memo f k))
forall {k} (f :: k -> *) k (r :: k). MemoF f k r -> Anno k (f r)
unMemoF (MemoF f k (Memo f k) -> Anno k (f (Memo f k)))
-> (Memo f k -> MemoF f k (Memo f k))
-> Memo f k
-> Anno k (f (Memo f k))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Memo f k -> MemoF f k (Memo f k)
forall (f :: * -> *) k. Memo f k -> MemoF f k (Memo f k)
unMemo

-- | Peek at the top value like 'annoRightM'
memoRightM :: (f (Memo f k) -> ReaderT k m x) -> Memo f k -> m x
memoRightM :: forall (f :: * -> *) k (m :: * -> *) x.
(f (Memo f k) -> ReaderT k m x) -> Memo f k -> m x
memoRightM f (Memo f k) -> ReaderT k m x
f = (f (Memo f k) -> ReaderT k m x) -> Anno k (f (Memo f k)) -> m x
forall v k (m :: * -> *) x. (v -> ReaderT k m x) -> Anno k v -> m x
annoRightM f (Memo f k) -> ReaderT k m x
f (Anno k (f (Memo f k)) -> m x)
-> (Memo f k -> Anno k (f (Memo f k))) -> Memo f k -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoF f k (Memo f k) -> Anno k (f (Memo f k))
forall {k} (f :: k -> *) k (r :: k). MemoF f k r -> Anno k (f r)
unMemoF (MemoF f k (Memo f k) -> Anno k (f (Memo f k)))
-> (Memo f k -> MemoF f k (Memo f k))
-> Memo f k
-> Anno k (f (Memo f k))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Memo f k -> MemoF f k (Memo f k)
forall (f :: * -> *) k. Memo f k -> MemoF f k (Memo f k)
unMemo

-- | Re-annotate top-down
memoExtend :: (Functor f) => (Memo f k -> x) -> Memo f k -> Memo f x
memoExtend :: forall (f :: * -> *) k x.
Functor f =>
(Memo f k -> x) -> Memo f k -> Memo f x
memoExtend Memo f k -> x
w = Memo f k -> Memo f x
go where go :: Memo f k -> Memo f x
go m :: Memo f k
m@(MemoP k
_ f (Memo f k)
v) = x -> f (Memo f x) -> Memo f x
forall k (f :: * -> *). k -> f (Memo f k) -> Memo f k
MemoP (Memo f k -> x
w Memo f k
m) ((Memo f k -> Memo f x) -> f (Memo f k) -> f (Memo f x)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Memo f k -> Memo f x
go f (Memo f k)
v)

-- | The base functor for a 'Jot'
newtype JotF g k a r = JotF {forall {k} {k} (g :: k -> k -> *) k (a :: k) (r :: k).
JotF g k a r -> Anno k (g a r)
unJotF :: Anno k (g a r)}
  deriving stock (Int -> JotF g k a r -> ShowS
[JotF g k a r] -> ShowS
JotF g k a r -> String
(Int -> JotF g k a r -> ShowS)
-> (JotF g k a r -> String)
-> ([JotF g k a r] -> ShowS)
-> Show (JotF g k a r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Show k, Show (g a r)) =>
Int -> JotF g k a r -> ShowS
forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Show k, Show (g a r)) =>
[JotF g k a r] -> ShowS
forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Show k, Show (g a r)) =>
JotF g k a r -> String
$cshowsPrec :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Show k, Show (g a r)) =>
Int -> JotF g k a r -> ShowS
showsPrec :: Int -> JotF g k a r -> ShowS
$cshow :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Show k, Show (g a r)) =>
JotF g k a r -> String
show :: JotF g k a r -> String
$cshowList :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Show k, Show (g a r)) =>
[JotF g k a r] -> ShowS
showList :: [JotF g k a r] -> ShowS
Show, (forall a b. (a -> b) -> JotF g k a a -> JotF g k a b)
-> (forall a b. a -> JotF g k a b -> JotF g k a a)
-> Functor (JotF g k a)
forall a b. a -> JotF g k a b -> JotF g k a a
forall a b. (a -> b) -> JotF g k a a -> JotF g k a b
forall k (g :: k -> * -> *) k (a :: k) a b.
Functor (g a) =>
a -> JotF g k a b -> JotF g k a a
forall k (g :: k -> * -> *) k (a :: k) a b.
Functor (g a) =>
(a -> b) -> JotF g k a a -> JotF g k a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall k (g :: k -> * -> *) k (a :: k) a b.
Functor (g a) =>
(a -> b) -> JotF g k a a -> JotF g k a b
fmap :: forall a b. (a -> b) -> JotF g k a a -> JotF g k a b
$c<$ :: forall k (g :: k -> * -> *) k (a :: k) a b.
Functor (g a) =>
a -> JotF g k a b -> JotF g k a a
<$ :: forall a b. a -> JotF g k a b -> JotF g k a a
Functor)
  deriving newtype (JotF g k a r -> JotF g k a r -> Bool
(JotF g k a r -> JotF g k a r -> Bool)
-> (JotF g k a r -> JotF g k a r -> Bool) -> Eq (JotF g k a r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Eq k, Eq (g a r)) =>
JotF g k a r -> JotF g k a r -> Bool
$c== :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Eq k, Eq (g a r)) =>
JotF g k a r -> JotF g k a r -> Bool
== :: JotF g k a r -> JotF g k a r -> Bool
$c/= :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Eq k, Eq (g a r)) =>
JotF g k a r -> JotF g k a r -> Bool
/= :: JotF g k a r -> JotF g k a r -> Bool
Eq, Eq (JotF g k a r)
Eq (JotF g k a r) =>
(JotF g k a r -> JotF g k a r -> Ordering)
-> (JotF g k a r -> JotF g k a r -> Bool)
-> (JotF g k a r -> JotF g k a r -> Bool)
-> (JotF g k a r -> JotF g k a r -> Bool)
-> (JotF g k a r -> JotF g k a r -> Bool)
-> (JotF g k a r -> JotF g k a r -> JotF g k a r)
-> (JotF g k a r -> JotF g k a r -> JotF g k a r)
-> Ord (JotF g k a r)
JotF g k a r -> JotF g k a r -> Bool
JotF g k a r -> JotF g k a r -> Ordering
JotF g k a r -> JotF g k a r -> JotF g k a r
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 k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Ord k, Ord (g a r)) =>
Eq (JotF g k a r)
forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Ord k, Ord (g a r)) =>
JotF g k a r -> JotF g k a r -> Bool
forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Ord k, Ord (g a r)) =>
JotF g k a r -> JotF g k a r -> Ordering
forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Ord k, Ord (g a r)) =>
JotF g k a r -> JotF g k a r -> JotF g k a r
$ccompare :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Ord k, Ord (g a r)) =>
JotF g k a r -> JotF g k a r -> Ordering
compare :: JotF g k a r -> JotF g k a r -> Ordering
$c< :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Ord k, Ord (g a r)) =>
JotF g k a r -> JotF g k a r -> Bool
< :: JotF g k a r -> JotF g k a r -> Bool
$c<= :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Ord k, Ord (g a r)) =>
JotF g k a r -> JotF g k a r -> Bool
<= :: JotF g k a r -> JotF g k a r -> Bool
$c> :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Ord k, Ord (g a r)) =>
JotF g k a r -> JotF g k a r -> Bool
> :: JotF g k a r -> JotF g k a r -> Bool
$c>= :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Ord k, Ord (g a r)) =>
JotF g k a r -> JotF g k a r -> Bool
>= :: JotF g k a r -> JotF g k a r -> Bool
$cmax :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Ord k, Ord (g a r)) =>
JotF g k a r -> JotF g k a r -> JotF g k a r
max :: JotF g k a r -> JotF g k a r -> JotF g k a r
$cmin :: forall k k (g :: k -> k -> *) k (a :: k) (r :: k).
(Ord k, Ord (g a r)) =>
JotF g k a r -> JotF g k a r -> JotF g k a r
min :: JotF g k a r -> JotF g k a r -> JotF g k a r
Ord)

pattern JotFP :: k -> g a r -> JotF g k a r
pattern $mJotFP :: forall {r} {k1} {k2} {k3} {g :: k1 -> k2 -> *} {a :: k1} {r :: k2}.
JotF g k3 a r -> (k3 -> g a r -> r) -> ((# #) -> r) -> r
$bJotFP :: forall {k1} {k2} k3 (g :: k1 -> k2 -> *) (a :: k1) (r :: k2).
k3 -> g a r -> JotF g k3 a r
JotFP k v = JotF (Anno k v)

{-# COMPLETE JotFP #-}

deriving newtype instance (Monoid k, IsString (g a r)) => IsString (JotF g k a r)

deriving newtype instance (Pretty (g a r)) => Pretty (JotF g k a r)

instance (Bifunctor g) => Bifunctor (JotF g k) where
  bimap :: forall a b c d.
(a -> b) -> (c -> d) -> JotF g k a c -> JotF g k b d
bimap a -> b
f c -> d
g = JotF g k a c -> JotF g k b d
go where go :: JotF g k a c -> JotF g k b d
go = Anno k (g b d) -> JotF g k b d
forall {k} {k} (g :: k -> k -> *) k (a :: k) (r :: k).
Anno k (g a r) -> JotF g k a r
JotF (Anno k (g b d) -> JotF g k b d)
-> (JotF g k a c -> Anno k (g b d)) -> JotF g k a c -> JotF g k b d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g a c -> g b d) -> Anno k (g a c) -> Anno k (g b d)
forall a b. (a -> b) -> Anno k a -> Anno k b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (c -> d) -> g a c -> g b d
forall a b c d. (a -> b) -> (c -> d) -> g a c -> g b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g) (Anno k (g a c) -> Anno k (g b d))
-> (JotF g k a c -> Anno k (g a c))
-> JotF g k a c
-> Anno k (g b d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JotF g k a c -> Anno k (g a c)
forall {k} {k} (g :: k -> k -> *) k (a :: k) (r :: k).
JotF g k a r -> Anno k (g a r)
unJotF

instance (Bifoldable g) => Bifoldable (JotF g k) where
  bifoldr :: forall a c b.
(a -> c -> c) -> (b -> c -> c) -> c -> JotF g k a b -> c
bifoldr a -> c -> c
f b -> c -> c
g = c -> JotF g k a b -> c
go where go :: c -> JotF g k a b -> c
go c
z = (a -> c -> c) -> (b -> c -> c) -> c -> g a b -> c
forall a c b. (a -> c -> c) -> (b -> c -> c) -> c -> g a b -> c
forall (p :: * -> * -> *) a c b.
Bifoldable p =>
(a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldr a -> c -> c
f b -> c -> c
g c
z (g a b -> c) -> (JotF g k a b -> g a b) -> JotF g k a b -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anno k (g a b) -> g a b
forall k v. Anno k v -> v
annoVal (Anno k (g a b) -> g a b)
-> (JotF g k a b -> Anno k (g a b)) -> JotF g k a b -> g a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JotF g k a b -> Anno k (g a b)
forall {k} {k} (g :: k -> k -> *) k (a :: k) (r :: k).
JotF g k a r -> Anno k (g a r)
unJotF

instance (Bitraversable g) => Bitraversable (JotF g k) where
  bitraverse :: forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> JotF g k a b -> f (JotF g k c d)
bitraverse a -> f c
f b -> f d
g = JotF g k a b -> f (JotF g k c d)
go where go :: JotF g k a b -> f (JotF g k c d)
go = (Anno k (g c d) -> JotF g k c d)
-> f (Anno k (g c d)) -> f (JotF g k c d)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Anno k (g c d) -> JotF g k c d
forall {k} {k} (g :: k -> k -> *) k (a :: k) (r :: k).
Anno k (g a r) -> JotF g k a r
JotF (f (Anno k (g c d)) -> f (JotF g k c d))
-> (JotF g k a b -> f (Anno k (g c d)))
-> JotF g k a b
-> f (JotF g k c d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g a b -> f (g c d)) -> Anno k (g a b) -> f (Anno k (g c d))
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) -> Anno k a -> f (Anno k b)
traverse ((a -> f c) -> (b -> f d) -> g a b -> f (g c d)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> g a b -> f (g c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f c
f b -> f d
g) (Anno k (g a b) -> f (Anno k (g c d)))
-> (JotF g k a b -> Anno k (g a b))
-> JotF g k a b
-> f (Anno k (g c d))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JotF g k a b -> Anno k (g a b)
forall {k} {k} (g :: k -> k -> *) k (a :: k) (r :: k).
JotF g k a r -> Anno k (g a r)
unJotF

jotFKey :: JotF g k a r -> k
jotFKey :: forall {k} {k} (g :: k -> k -> *) k (a :: k) (r :: k).
JotF g k a r -> k
jotFKey (JotFP k
k g a r
_) = k
k

jotFVal :: JotF g k a r -> g a r
jotFVal :: forall {k} {k} (g :: k -> k -> *) k (a :: k) (r :: k).
JotF g k a r -> g a r
jotFVal (JotFP k
_ g a r
v) = g a r
v

-- | An annotated 'Knot'
type Jot :: (Type -> Type -> Type) -> Type -> Type -> Type
newtype Jot g k a = Jot {forall (g :: * -> * -> *) k a. Jot g k a -> JotF g k a (Jot g k a)
unJot :: JotF g k a (Jot g k a)}

pattern JotP :: k -> g a (Jot g k a) -> Jot g k a
pattern $mJotP :: forall {r} {k} {g :: * -> * -> *} {a}.
Jot g k a -> (k -> g a (Jot g k a) -> r) -> ((# #) -> r) -> r
$bJotP :: forall k (g :: * -> * -> *) a. k -> g a (Jot g k a) -> Jot g k a
JotP k v = Jot (JotF (Anno k v))

{-# COMPLETE JotP #-}

deriving newtype instance (Eq k, Eq (g a (Jot g k a))) => Eq (Jot g k a)

deriving newtype instance (Ord k, Ord (g a (Jot g k a))) => Ord (Jot g k a)

deriving stock instance (Show k, Show (g a (Jot g k a))) => Show (Jot g k a)

deriving newtype instance (Monoid k, IsString (g a (Jot g k a))) => IsString (Jot g k a)

deriving newtype instance (Pretty (g a (Jot g k a))) => Pretty (Jot g k a)

type instance Base1 (Jot g k) = JotF g k

instance (Bifunctor g) => Recursive1 (Jot g k) where project1 :: forall a. Jot g k a -> Base1 (Jot g k) a (Jot g k a)
project1 = Jot g k a -> JotF g k a (Jot g k a)
Jot g k a -> Base1 (Jot g k) a (Jot g k a)
forall (g :: * -> * -> *) k a. Jot g k a -> JotF g k a (Jot g k a)
unJot

instance (Bifunctor g) => Corecursive1 (Jot g k) where embed1 :: forall a. Base1 (Jot g k) a (Jot g k a) -> Jot g k a
embed1 = JotF g k a (Jot g k a) -> Jot g k a
Base1 (Jot g k) a (Jot g k a) -> Jot g k a
forall (g :: * -> * -> *) k a. JotF g k a (Jot g k a) -> Jot g k a
Jot

instance (Bifunctor g) => Functor (Jot g k) where fmap :: forall a b. (a -> b) -> Jot g k a -> Jot g k b
fmap = (a -> b) -> Jot g k a -> Jot g k b
forall (f :: * -> *) (g :: * -> * -> *) a b.
(Recursive1 f, Corecursive1 f, Base1 f ~ g) =>
(a -> b) -> f a -> f b
fmapViaBi

instance (Bifunctor g, Bifoldable g) => Foldable (Jot g k) where foldr :: forall a b. (a -> b -> b) -> b -> Jot g k a -> b
foldr = (a -> b -> b) -> b -> Jot g k a -> b
forall (f :: * -> *) (g :: * -> * -> *) a b.
(Recursive1 f, Base1 f ~ g, Bifoldable g) =>
(a -> b -> b) -> b -> f a -> b
foldrViaBi

instance (Bitraversable g) => Traversable (Jot g k) where traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Jot g k a -> f (Jot g k b)
traverse = (a -> f b) -> Jot g k a -> f (Jot g k b)
forall (f :: * -> *) (g :: * -> * -> *) (m :: * -> *) a b.
(Recursive1 f, Corecursive1 f, Base1 f ~ g, Bitraversable g,
 Applicative m) =>
(a -> m b) -> f a -> m (f b)
traverseViaBi

instance (Bifunctor g) => Bifunctor (Jot g) where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> Jot g a c -> Jot g b d
bimap a -> b
f c -> d
g = Jot g a c -> Jot g b d
go where go :: Jot g a c -> Jot g b d
go (JotP a
k g c (Jot g a c)
v) = b -> g d (Jot g b d) -> Jot g b d
forall k (g :: * -> * -> *) a. k -> g a (Jot g k a) -> Jot g k a
JotP (a -> b
f a
k) ((c -> d)
-> (Jot g a c -> Jot g b d) -> g c (Jot g a c) -> g d (Jot g b d)
forall a b c d. (a -> b) -> (c -> d) -> g a c -> g b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap c -> d
g Jot g a c -> Jot g b d
go g c (Jot g a c)
v)

instance (Bifoldable g) => Bifoldable (Jot g) where
  bifoldr :: forall a c b. (a -> c -> c) -> (b -> c -> c) -> c -> Jot g a b -> c
bifoldr a -> c -> c
f b -> c -> c
g = (Jot g a b -> c -> c) -> c -> Jot g a b -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip Jot g a b -> c -> c
go where go :: Jot g a b -> c -> c
go (JotP a
k g b (Jot g a b)
v) c
z = a -> c -> c
f a
k ((b -> c -> c) -> (Jot g a b -> c -> c) -> c -> g b (Jot g a b) -> c
forall a c b. (a -> c -> c) -> (b -> c -> c) -> c -> g a b -> c
forall (p :: * -> * -> *) a c b.
Bifoldable p =>
(a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldr b -> c -> c
g Jot g a b -> c -> c
go c
z g b (Jot g a b)
v)

instance (Bitraversable g) => Bitraversable (Jot g) where
  bitraverse :: forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Jot g a b -> f (Jot g c d)
bitraverse a -> f c
f b -> f d
g = Jot g a b -> f (Jot g c d)
go where go :: Jot g a b -> f (Jot g c d)
go (JotP a
k g b (Jot g a b)
v) = (c -> g d (Jot g c d) -> Jot g c d)
-> f c -> f (g d (Jot g c d)) -> f (Jot g c d)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 c -> g d (Jot g c d) -> Jot g c d
forall k (g :: * -> * -> *) a. k -> g a (Jot g k a) -> Jot g k a
JotP (a -> f c
f a
k) ((b -> f d)
-> (Jot g a b -> f (Jot g c d))
-> g b (Jot g a b)
-> f (g d (Jot g c d))
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> g a b -> f (g c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse b -> f d
g Jot g a b -> f (Jot g c d)
go g b (Jot g a b)
v)

-- | Pull a recursive structure apart and retie as a 'Jot', using the given
-- function to calculate a key for every level.
mkJot :: (Recursive1 t, Base1 t ~ g) => (g a k -> k) -> t a -> Jot g k a
mkJot :: forall (t :: * -> *) (g :: * -> * -> *) a k.
(Recursive1 t, Base1 t ~ g) =>
(g a k -> k) -> t a -> Jot g k a
mkJot g a k -> k
f = (g a (Jot g k a) -> Jot g k a) -> t a -> Jot g k a
forall (f :: * -> *) (g :: * -> * -> *) a b.
(Recursive1 f, Base1 f ~ g) =>
(g a b -> b) -> f a -> b
cata1 (\g a (Jot g k a)
v -> k -> g a (Jot g k a) -> Jot g k a
forall k (g :: * -> * -> *) a. k -> g a (Jot g k a) -> Jot g k a
JotP (g a k -> k
f ((Jot g k a -> k) -> g a (Jot g k a) -> g a k
forall a b. (a -> b) -> g a a -> g a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Jot g k a -> k
forall (g :: * -> * -> *) k a. Jot g k a -> k
jotKey g a (Jot g k a)
v)) g a (Jot g k a)
v)

-- | Forget keys at every level and convert back to a plain structure.
unMkJot :: (Corecursive1 t, Base1 t ~ g) => Jot g k a -> t a
unMkJot :: forall (t :: * -> *) (g :: * -> * -> *) k a.
(Corecursive1 t, Base1 t ~ g) =>
Jot g k a -> t a
unMkJot (JotP k
_ g a (Jot g k a)
v) = Base1 t a (t a) -> t a
forall a. Base1 t a (t a) -> t a
forall (f :: * -> *) a. Corecursive1 f => Base1 f a (f a) -> f a
embed1 ((Jot g k a -> t a) -> g a (Jot g k a) -> g a (t a)
forall a b. (a -> b) -> g a a -> g a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Jot g k a -> t a
forall (t :: * -> *) (g :: * -> * -> *) k a.
(Corecursive1 t, Base1 t ~ g) =>
Jot g k a -> t a
unMkJot g a (Jot g k a)
v)

-- | Quick conversion from annotated functor.
annoJot :: Anno b (g a (Jot g b a)) -> Jot g b a
annoJot :: forall b (g :: * -> * -> *) a.
Anno b (g a (Jot g b a)) -> Jot g b a
annoJot = JotF g b a (Jot g b a) -> Jot g b a
forall (g :: * -> * -> *) k a. JotF g k a (Jot g k a) -> Jot g k a
Jot (JotF g b a (Jot g b a) -> Jot g b a)
-> (Anno b (g a (Jot g b a)) -> JotF g b a (Jot g b a))
-> Anno b (g a (Jot g b a))
-> Jot g b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anno b (g a (Jot g b a)) -> JotF g b a (Jot g b a)
forall {k} {k} (g :: k -> k -> *) k (a :: k) (r :: k).
Anno k (g a r) -> JotF g k a r
JotF

-- | Transform the base functor.
transJot :: (Bifunctor g) => (forall x. g a x -> h a x) -> Jot g k a -> Jot h k a
transJot :: forall (g :: * -> * -> *) a (h :: * -> * -> *) k.
Bifunctor g =>
(forall x. g a x -> h a x) -> Jot g k a -> Jot h k a
transJot forall x. g a x -> h a x
nat = Jot g k a -> Jot h k a
go
 where
  go :: Jot g k a -> Jot h k a
go (JotP k
k g a (Jot g k a)
v) = k -> h a (Jot h k a) -> Jot h k a
forall k (g :: * -> * -> *) a. k -> g a (Jot g k a) -> Jot g k a
JotP k
k (g a (Jot h k a) -> h a (Jot h k a)
forall x. g a x -> h a x
nat ((Jot g k a -> Jot h k a) -> g a (Jot g k a) -> g a (Jot h k a)
forall b c a. (b -> c) -> g a b -> g a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Jot g k a -> Jot h k a
go g a (Jot g k a)
v))

jotKey :: Jot g k a -> k
jotKey :: forall (g :: * -> * -> *) k a. Jot g k a -> k
jotKey (JotP k
k g a (Jot g k a)
_) = k
k

jotVal :: Jot g k a -> g a (Jot g k a)
jotVal :: forall (g :: * -> * -> *) k a. Jot g k a -> g a (Jot g k a)
jotVal (JotP k
_ g a (Jot g k a)
v) = g a (Jot g k a)
v

-- | 'cata' but nicer
jotCata :: (Bifunctor g) => (g a x -> Reader k x) -> Jot g k a -> x
jotCata :: forall (g :: * -> * -> *) a x k.
Bifunctor g =>
(g a x -> Reader k x) -> Jot g k a -> x
jotCata g a x -> Reader k x
f = Jot g k a -> x
go
 where
  go :: Jot g k a -> x
go (JotP k
k g a (Jot g k a)
v) = Reader k x -> k -> x
forall r a. Reader r a -> r -> a
runReader (g a x -> Reader k x
f ((Jot g k a -> x) -> g a (Jot g k a) -> g a x
forall a b. (a -> b) -> g a a -> g a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Jot g k a -> x
go g a (Jot g k a)
v)) k
k

-- | 'cataM' but nicer
jotCataM :: (Bifunctor g) => (g a (m x) -> ReaderT k m x) -> Jot g k a -> m x
jotCataM :: forall (g :: * -> * -> *) a (m :: * -> *) x k.
Bifunctor g =>
(g a (m x) -> ReaderT k m x) -> Jot g k a -> m x
jotCataM g a (m x) -> ReaderT k m x
f = Jot g k a -> m x
go
 where
  go :: Jot g k a -> m x
go (JotP k
k g a (Jot g k a)
v) = ReaderT k m x -> k -> m x
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (g a (m x) -> ReaderT k m x
f ((Jot g k a -> m x) -> g a (Jot g k a) -> g a (m x)
forall a b. (a -> b) -> g a a -> g a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Jot g k a -> m x
go g a (Jot g k a)
v)) k
k

-- | Peek at the top value like 'annoRight'
jotRight :: (g a (Jot g k a) -> Reader k x) -> Jot g k a -> x
jotRight :: forall (g :: * -> * -> *) a k x.
(g a (Jot g k a) -> Reader k x) -> Jot g k a -> x
jotRight g a (Jot g k a) -> Reader k x
f = (g a (Jot g k a) -> Reader k x) -> Anno k (g a (Jot g k a)) -> x
forall v k x. (v -> Reader k x) -> Anno k v -> x
annoRight g a (Jot g k a) -> Reader k x
f (Anno k (g a (Jot g k a)) -> x)
-> (Jot g k a -> Anno k (g a (Jot g k a))) -> Jot g k a -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JotF g k a (Jot g k a) -> Anno k (g a (Jot g k a))
forall {k} {k} (g :: k -> k -> *) k (a :: k) (r :: k).
JotF g k a r -> Anno k (g a r)
unJotF (JotF g k a (Jot g k a) -> Anno k (g a (Jot g k a)))
-> (Jot g k a -> JotF g k a (Jot g k a))
-> Jot g k a
-> Anno k (g a (Jot g k a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Jot g k a -> JotF g k a (Jot g k a)
forall (g :: * -> * -> *) k a. Jot g k a -> JotF g k a (Jot g k a)
unJot

-- | Peek at the top value like 'annoRightM'
jotRightM :: (g a (Jot g k a) -> ReaderT k m x) -> Jot g k a -> m x
jotRightM :: forall (g :: * -> * -> *) a k (m :: * -> *) x.
(g a (Jot g k a) -> ReaderT k m x) -> Jot g k a -> m x
jotRightM g a (Jot g k a) -> ReaderT k m x
f = (g a (Jot g k a) -> ReaderT k m x)
-> Anno k (g a (Jot g k a)) -> m x
forall v k (m :: * -> *) x. (v -> ReaderT k m x) -> Anno k v -> m x
annoRightM g a (Jot g k a) -> ReaderT k m x
f (Anno k (g a (Jot g k a)) -> m x)
-> (Jot g k a -> Anno k (g a (Jot g k a))) -> Jot g k a -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JotF g k a (Jot g k a) -> Anno k (g a (Jot g k a))
forall {k} {k} (g :: k -> k -> *) k (a :: k) (r :: k).
JotF g k a r -> Anno k (g a r)
unJotF (JotF g k a (Jot g k a) -> Anno k (g a (Jot g k a)))
-> (Jot g k a -> JotF g k a (Jot g k a))
-> Jot g k a
-> Anno k (g a (Jot g k a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Jot g k a -> JotF g k a (Jot g k a)
forall (g :: * -> * -> *) k a. Jot g k a -> JotF g k a (Jot g k a)
unJot

-- | Re-annotate top-down
jotExtend :: (Bifunctor g) => (Jot g k a -> x) -> Jot g k a -> Jot g x a
jotExtend :: forall (g :: * -> * -> *) k a x.
Bifunctor g =>
(Jot g k a -> x) -> Jot g k a -> Jot g x a
jotExtend Jot g k a -> x
w = Jot g k a -> Jot g x a
go where go :: Jot g k a -> Jot g x a
go j :: Jot g k a
j@(JotP k
_ g a (Jot g k a)
v) = x -> g a (Jot g x a) -> Jot g x a
forall k (g :: * -> * -> *) a. k -> g a (Jot g k a) -> Jot g k a
JotP (Jot g k a -> x
w Jot g k a
j) ((Jot g k a -> Jot g x a) -> g a (Jot g k a) -> g a (Jot g x a)
forall a b. (a -> b) -> g a a -> g a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Jot g k a -> Jot g x a
go g a (Jot g k a)
v)