module Bowtie.Anno
  ( Anno (..)
  , annoUnit
  , annoUnitM
  , annoCounit
  , annoCounitM
  , annoLeft
  , annoLeftM
  , annoRight
  , annoRightM
  )
where

import Control.Comonad (Comonad (..))
import Control.Exception (Exception)
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.Identity (Identity (..))
import Data.Kind (Type)
import Data.String (IsString (..))
import Data.Typeable (Typeable)
import Prettyprinter (Pretty (..))

-- | 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