{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE RoleAnnotations #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Internal.Magma
-- Copyright   :  (C) 2012-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
----------------------------------------------------------------------------
module Control.Lens.Internal.Magma
  (
  -- * Magma
    Magma(..)
  , runMagma
  -- * Molten
  , Molten(..)
  -- * Mafic
  , Mafic(..)
  , runMafic
  -- * TakingWhile
  , TakingWhile(..)
  , runTakingWhile
  ) where

import Control.Applicative
import Control.Category
import Control.Comonad
import Control.Lens.Internal.Bazaar
import Control.Lens.Internal.Context
import Control.Lens.Internal.Indexed
import Data.Foldable
import Data.Functor.Apply
import Data.Functor.Contravariant
import Data.Monoid
import Data.Profunctor.Rep
import Data.Profunctor.Sieve
import Data.Profunctor.Unsafe
import Data.Traversable
import Prelude hiding ((.),id)

------------------------------------------------------------------------------
-- Magma
------------------------------------------------------------------------------

-- | This provides a way to peek at the internal structure of a
-- 'Control.Lens.Traversal.Traversal' or 'Control.Lens.Traversal.IndexedTraversal'
data Magma i t b a where
  MagmaAp   :: Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a
  MagmaPure :: x -> Magma i x b a
  MagmaFmap :: (x -> y) -> Magma i x b a -> Magma i y b a
  Magma :: i -> a -> Magma i b b a

#if __GLASGOW_HASKELL__ >= 707
-- note the 3rd argument infers as phantom, but that would be unsound
type role Magma representational nominal nominal nominal
#endif

instance Functor (Magma i t b) where
  fmap :: (a -> b) -> Magma i t b a -> Magma i t b b
fmap f :: a -> b
f (MagmaAp x :: Magma i (x -> t) b a
x y :: Magma i x b a
y)    = Magma i (x -> t) b b -> Magma i x b b -> Magma i t b b
forall i x y b a.
Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a
MagmaAp ((a -> b) -> Magma i (x -> t) b a -> Magma i (x -> t) b b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Magma i (x -> t) b a
x) ((a -> b) -> Magma i x b a -> Magma i x b b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Magma i x b a
y)
  fmap _ (MagmaPure x :: t
x)    = t -> Magma i t b b
forall x i b a. x -> Magma i x b a
MagmaPure t
x
  fmap f :: a -> b
f (MagmaFmap xy :: x -> t
xy x :: Magma i x b a
x) = (x -> t) -> Magma i x b b -> Magma i t b b
forall x y i b a. (x -> y) -> Magma i x b a -> Magma i y b a
MagmaFmap x -> t
xy ((a -> b) -> Magma i x b a -> Magma i x b b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Magma i x b a
x)
  fmap f :: a -> b
f (Magma i :: i
i a :: a
a)  = i -> b -> Magma i t t b
forall i a b. i -> a -> Magma i b b a
Magma i
i (a -> b
f a
a)

instance Foldable (Magma i t b) where
  foldMap :: (a -> m) -> Magma i t b a -> m
foldMap f :: a -> m
f (MagmaAp x :: Magma i (x -> t) b a
x y :: Magma i x b a
y)   = (a -> m) -> Magma i (x -> t) b a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Magma i (x -> t) b a
x m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` (a -> m) -> Magma i x b a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Magma i x b a
y
  foldMap _ MagmaPure{}     = m
forall a. Monoid a => a
mempty
  foldMap f :: a -> m
f (MagmaFmap _ x :: Magma i x b a
x) = (a -> m) -> Magma i x b a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Magma i x b a
x
  foldMap f :: a -> m
f (Magma _ a :: a
a) = a -> m
f a
a

instance Traversable (Magma i t b) where
  traverse :: (a -> f b) -> Magma i t b a -> f (Magma i t b b)
traverse f :: a -> f b
f (MagmaAp x :: Magma i (x -> t) b a
x y :: Magma i x b a
y)    = Magma i (x -> t) b b -> Magma i x b b -> Magma i t b b
forall i x y b a.
Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a
MagmaAp (Magma i (x -> t) b b -> Magma i x b b -> Magma i t b b)
-> f (Magma i (x -> t) b b) -> f (Magma i x b b -> Magma i t b b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Magma i (x -> t) b a -> f (Magma i (x -> t) b b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Magma i (x -> t) b a
x f (Magma i x b b -> Magma i t b b)
-> f (Magma i x b b) -> f (Magma i t b b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f b) -> Magma i x b a -> f (Magma i x b b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Magma i x b a
y
  traverse _ (MagmaPure x :: t
x)    = Magma i t b b -> f (Magma i t b b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> Magma i t b b
forall x i b a. x -> Magma i x b a
MagmaPure t
x)
  traverse f :: a -> f b
f (MagmaFmap xy :: x -> t
xy x :: Magma i x b a
x) = (x -> t) -> Magma i x b b -> Magma i t b b
forall x y i b a. (x -> y) -> Magma i x b a -> Magma i y b a
MagmaFmap x -> t
xy (Magma i x b b -> Magma i t b b)
-> f (Magma i x b b) -> f (Magma i t b b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Magma i x b a -> f (Magma i x b b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Magma i x b a
x
  traverse f :: a -> f b
f (Magma i :: i
i a :: a
a)  = i -> b -> Magma i t t b
forall i a b. i -> a -> Magma i b b a
Magma i
i (b -> Magma i t t b) -> f b -> f (Magma i t t b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a

instance (Show i, Show a) => Show (Magma i t b a) where
  showsPrec :: Int -> Magma i t b a -> ShowS
showsPrec d :: Int
d (MagmaAp x :: Magma i (x -> t) b a
x y :: Magma i x b a
y) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 4) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    Int -> Magma i (x -> t) b a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 4 Magma i (x -> t) b a
x ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> ShowS
showString " <*> " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Magma i x b a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 5 Magma i x b a
y
  showsPrec d :: Int
d (MagmaPure _) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString "pure .."
  showsPrec d :: Int
d (MagmaFmap _ x :: Magma i x b a
x) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 4) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString ".. <$> " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Magma i x b a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 5 Magma i x b a
x
  showsPrec d :: Int
d (Magma i :: i
i a :: a
a) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString "Magma " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> i -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 i
i ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> ShowS
showChar ' ' ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 a
a

-- | Run a 'Magma' where all the individual leaves have been converted to the
-- expected type
runMagma :: Magma i t a a -> t
runMagma :: Magma i t a a -> t
runMagma (MagmaAp l :: Magma i (x -> t) a a
l r :: Magma i x a a
r)   = Magma i (x -> t) a a -> x -> t
forall i t a. Magma i t a a -> t
runMagma Magma i (x -> t) a a
l (Magma i x a a -> x
forall i t a. Magma i t a a -> t
runMagma Magma i x a a
r)
runMagma (MagmaFmap f :: x -> t
f r :: Magma i x a a
r) = x -> t
f (Magma i x a a -> x
forall i t a. Magma i t a a -> t
runMagma Magma i x a a
r)
runMagma (MagmaPure x :: t
x)   = t
x
runMagma (Magma _ a :: a
a) = t
a
a

------------------------------------------------------------------------------
-- Molten
------------------------------------------------------------------------------

-- | This is a a non-reassociating initially encoded version of 'Bazaar'.
newtype Molten i a b t = Molten { Molten i a b t -> Magma i t b a
runMolten :: Magma i t b a }

instance Functor (Molten i a b) where
  fmap :: (a -> b) -> Molten i a b a -> Molten i a b b
fmap f :: a -> b
f (Molten xs :: Magma i a b a
xs) = Magma i b b a -> Molten i a b b
forall i a b t. Magma i t b a -> Molten i a b t
Molten ((a -> b) -> Magma i a b a -> Magma i b b a
forall x y i b a. (x -> y) -> Magma i x b a -> Magma i y b a
MagmaFmap a -> b
f Magma i a b a
xs)
  {-# INLINE fmap #-}

instance Apply (Molten i a b) where
  <.> :: Molten i a b (a -> b) -> Molten i a b a -> Molten i a b b
(<.>) = Molten i a b (a -> b) -> Molten i a b a -> Molten i a b b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
  {-# INLINE (<.>) #-}

instance Applicative (Molten i a b) where
  pure :: a -> Molten i a b a
pure  = Magma i a b a -> Molten i a b a
forall i a b t. Magma i t b a -> Molten i a b t
Molten (Magma i a b a -> Molten i a b a)
-> (a -> Magma i a b a) -> a -> Molten i a b a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> Magma i a b a
forall x i b a. x -> Magma i x b a
MagmaPure
  {-# INLINE pure #-}
  Molten xs :: Magma i (a -> b) b a
xs <*> :: Molten i a b (a -> b) -> Molten i a b a -> Molten i a b b
<*> Molten ys :: Magma i a b a
ys = Magma i b b a -> Molten i a b b
forall i a b t. Magma i t b a -> Molten i a b t
Molten (Magma i (a -> b) b a -> Magma i a b a -> Magma i b b a
forall i x y b a.
Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a
MagmaAp Magma i (a -> b) b a
xs Magma i a b a
ys)
  {-# INLINE (<*>) #-}

instance Sellable (Indexed i) (Molten i) where
  sell :: Indexed i a (Molten i a b b)
sell = (i -> a -> Molten i a b b) -> Indexed i a (Molten i a b b)
forall i a b. (i -> a -> b) -> Indexed i a b
Indexed (\i :: i
i -> Magma i b b a -> Molten i a b b
forall i a b t. Magma i t b a -> Molten i a b t
Molten (Magma i b b a -> Molten i a b b)
-> (a -> Magma i b b a) -> a -> Molten i a b b
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. i -> a -> Magma i b b a
forall i a b. i -> a -> Magma i b b a
Magma i
i)
  {-# INLINE sell #-}

instance Bizarre (Indexed i) (Molten i) where
  bazaar :: Indexed i a (f b) -> Molten i a b t -> f t
bazaar f :: Indexed i a (f b)
f (Molten (MagmaAp x :: Magma i (x -> t) b a
x y :: Magma i x b a
y))   = Indexed i a (f b) -> Molten i a b (x -> t) -> f (x -> t)
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) (f :: * -> *) a b
       t.
(Bizarre p w, Applicative f) =>
p a (f b) -> w a b t -> f t
bazaar Indexed i a (f b)
f (Magma i (x -> t) b a -> Molten i a b (x -> t)
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i (x -> t) b a
x) f (x -> t) -> f x -> f t
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Indexed i a (f b) -> Molten i a b x -> f x
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) (f :: * -> *) a b
       t.
(Bizarre p w, Applicative f) =>
p a (f b) -> w a b t -> f t
bazaar Indexed i a (f b)
f (Magma i x b a -> Molten i a b x
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i x b a
y)
  bazaar f :: Indexed i a (f b)
f (Molten (MagmaFmap g :: x -> t
g x :: Magma i x b a
x)) = x -> t
g (x -> t) -> f x -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Indexed i a (f b) -> Molten i a b x -> f x
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) (f :: * -> *) a b
       t.
(Bizarre p w, Applicative f) =>
p a (f b) -> w a b t -> f t
bazaar Indexed i a (f b)
f (Magma i x b a -> Molten i a b x
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i x b a
x)
  bazaar _ (Molten (MagmaPure x :: t
x))   = t -> f t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
x
  bazaar f :: Indexed i a (f b)
f (Molten (Magma i :: i
i a :: a
a)) = Indexed i a (f b) -> i -> a -> f b
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed Indexed i a (f b)
f i
i a
a

instance IndexedFunctor (Molten i) where
  ifmap :: (s -> t) -> Molten i a b s -> Molten i a b t
ifmap f :: s -> t
f (Molten xs :: Magma i s b a
xs) = Magma i t b a -> Molten i a b t
forall i a b t. Magma i t b a -> Molten i a b t
Molten ((s -> t) -> Magma i s b a -> Magma i t b a
forall x y i b a. (x -> y) -> Magma i x b a -> Magma i y b a
MagmaFmap s -> t
f Magma i s b a
xs)
  {-# INLINE ifmap #-}

instance IndexedComonad (Molten i) where
  iextract :: Molten i a a t -> t
iextract (Molten (MagmaAp x :: Magma i (x -> t) a a
x y :: Magma i x a a
y))   = Molten i a a (x -> t) -> x -> t
forall (w :: * -> * -> * -> *) a t.
IndexedComonad w =>
w a a t -> t
iextract (Magma i (x -> t) a a -> Molten i a a (x -> t)
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i (x -> t) a a
x) (Molten i a a x -> x
forall (w :: * -> * -> * -> *) a t.
IndexedComonad w =>
w a a t -> t
iextract (Magma i x a a -> Molten i a a x
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i x a a
y))
  iextract (Molten (MagmaFmap f :: x -> t
f y :: Magma i x a a
y)) = x -> t
f (Molten i a a x -> x
forall (w :: * -> * -> * -> *) a t.
IndexedComonad w =>
w a a t -> t
iextract (Magma i x a a -> Molten i a a x
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i x a a
y))
  iextract (Molten (MagmaPure x :: t
x))   = t
x
  iextract (Molten (Magma _ a :: a
a)) = a
t
a

  iduplicate :: Molten i a c t -> Molten i a b (Molten i b c t)
iduplicate (Molten (Magma i :: i
i a :: a
a)) = Magma i t t b -> Molten i b t t
forall i a b t. Magma i t b a -> Molten i a b t
Molten (Magma i t t b -> Molten i b t t)
-> (b -> Magma i t t b) -> b -> Molten i b t t
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. i -> b -> Magma i t t b
forall i a b. i -> a -> Magma i b b a
Magma i
i (b -> Molten i b c t)
-> Molten i a b b -> Molten i a b (Molten i b c t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Magma i b b a -> Molten i a b b
forall i a b t. Magma i t b a -> Molten i a b t
Molten (i -> a -> Magma i b b a
forall i a b. i -> a -> Magma i b b a
Magma i
i a
a)
  iduplicate (Molten (MagmaPure x :: t
x))   = Molten i b c t -> Molten i a b (Molten i b c t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> Molten i b c t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
x)
  iduplicate (Molten (MagmaFmap f :: x -> t
f y :: Magma i x c a
y)) = (Molten i b c x -> Molten i b c t)
-> Molten i a c x -> Molten i a b (Molten i b c t)
forall (w :: * -> * -> * -> *) b c t r a.
IndexedComonad w =>
(w b c t -> r) -> w a c t -> w a b r
iextend ((x -> t) -> Molten i b c x -> Molten i b c t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x -> t
f) (Magma i x c a -> Molten i a c x
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i x c a
y)
  iduplicate (Molten (MagmaAp x :: Magma i (x -> t) c a
x y :: Magma i x c a
y))   = (Molten i b c (x -> t) -> Molten i b c x -> Molten i b c t)
-> Molten i a c (x -> t)
-> Molten i a b (Molten i b c x -> Molten i b c t)
forall (w :: * -> * -> * -> *) b c t r a.
IndexedComonad w =>
(w b c t -> r) -> w a c t -> w a b r
iextend Molten i b c (x -> t) -> Molten i b c x -> Molten i b c t
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (Magma i (x -> t) c a -> Molten i a c (x -> t)
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i (x -> t) c a
x) Molten i a b (Molten i b c x -> Molten i b c t)
-> Molten i a b (Molten i b c x) -> Molten i a b (Molten i b c t)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Molten i a c x -> Molten i a b (Molten i b c x)
forall (w :: * -> * -> * -> *) a c t b.
IndexedComonad w =>
w a c t -> w a b (w b c t)
iduplicate (Magma i x c a -> Molten i a c x
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i x c a
y)

  iextend :: (Molten i b c t -> r) -> Molten i a c t -> Molten i a b r
iextend k :: Molten i b c t -> r
k (Molten (Magma i :: i
i a :: a
a)) = (Molten i b c t -> r
Molten i b t t -> r
k (Molten i b t t -> r)
-> (Magma i t t b -> Molten i b t t) -> Magma i t t b -> r
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# Magma i t t b -> Molten i b t t
forall i a b t. Magma i t b a -> Molten i a b t
Molten) (Magma i t t b -> r) -> (b -> Magma i t t b) -> b -> r
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. i -> b -> Magma i t t b
forall i a b. i -> a -> Magma i b b a
Magma i
i (b -> r) -> Molten i a b b -> Molten i a b r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Magma i b b a -> Molten i a b b
forall i a b t. Magma i t b a -> Molten i a b t
Molten (i -> a -> Magma i b b a
forall i a b. i -> a -> Magma i b b a
Magma i
i a
a)
  iextend k :: Molten i b c t -> r
k (Molten (MagmaPure x :: t
x))   = r -> Molten i a b r
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Molten i b c t -> r
k (t -> Molten i b c t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
x))
  iextend k :: Molten i b c t -> r
k (Molten (MagmaFmap f :: x -> t
f y :: Magma i x c a
y)) = (Molten i b c x -> r) -> Molten i a c x -> Molten i a b r
forall (w :: * -> * -> * -> *) b c t r a.
IndexedComonad w =>
(w b c t -> r) -> w a c t -> w a b r
iextend (Molten i b c t -> r
k (Molten i b c t -> r)
-> (Molten i b c x -> Molten i b c t) -> Molten i b c x -> r
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (x -> t) -> Molten i b c x -> Molten i b c t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x -> t
f) (Magma i x c a -> Molten i a c x
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i x c a
y)
  iextend k :: Molten i b c t -> r
k (Molten (MagmaAp x :: Magma i (x -> t) c a
x y :: Magma i x c a
y))   = (Molten i b c (x -> t) -> Molten i b c x -> r)
-> Molten i a c (x -> t) -> Molten i a b (Molten i b c x -> r)
forall (w :: * -> * -> * -> *) b c t r a.
IndexedComonad w =>
(w b c t -> r) -> w a c t -> w a b r
iextend (\x' :: Molten i b c (x -> t)
x' y' :: Molten i b c x
y' -> Molten i b c t -> r
k (Molten i b c t -> r) -> Molten i b c t -> r
forall a b. (a -> b) -> a -> b
$ Molten i b c (x -> t)
x' Molten i b c (x -> t) -> Molten i b c x -> Molten i b c t
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Molten i b c x
y') (Magma i (x -> t) c a -> Molten i a c (x -> t)
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i (x -> t) c a
x) Molten i a b (Molten i b c x -> r)
-> Molten i a b (Molten i b c x) -> Molten i a b r
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Molten i a c x -> Molten i a b (Molten i b c x)
forall (w :: * -> * -> * -> *) a c t b.
IndexedComonad w =>
w a c t -> w a b (w b c t)
iduplicate (Magma i x c a -> Molten i a c x
forall i a b t. Magma i t b a -> Molten i a b t
Molten Magma i x c a
y)

instance a ~ b => Comonad (Molten i a b) where
  extract :: Molten i a b a -> a
extract   = Molten i a b a -> a
forall (w :: * -> * -> * -> *) a t.
IndexedComonad w =>
w a a t -> t
iextract
  {-# INLINE extract #-}
  extend :: (Molten i a b a -> b) -> Molten i a b a -> Molten i a b b
extend    = (Molten i a b a -> b) -> Molten i a b a -> Molten i a b b
forall (w :: * -> * -> * -> *) b c t r a.
IndexedComonad w =>
(w b c t -> r) -> w a c t -> w a b r
iextend
  {-# INLINE extend #-}
  duplicate :: Molten i a b a -> Molten i a b (Molten i a b a)
duplicate = Molten i a b a -> Molten i a b (Molten i a b a)
forall (w :: * -> * -> * -> *) a c t b.
IndexedComonad w =>
w a c t -> w a b (w b c t)
iduplicate
  {-# INLINE duplicate #-}

------------------------------------------------------------------------------
-- Mafic
------------------------------------------------------------------------------

-- | This is used to generate an indexed magma from an unindexed source
--
-- By constructing it this way we avoid infinite reassociations in sums where possible.
data Mafic a b t = Mafic Int (Int -> Magma Int t b a)

-- | Generate a 'Magma' using from a prefix sum.
runMafic :: Mafic a b t -> Magma Int t b a
runMafic :: Mafic a b t -> Magma Int t b a
runMafic (Mafic _ k :: Int -> Magma Int t b a
k) = Int -> Magma Int t b a
k 0

instance Functor (Mafic a b) where
  fmap :: (a -> b) -> Mafic a b a -> Mafic a b b
fmap f :: a -> b
f (Mafic w :: Int
w k :: Int -> Magma Int a b a
k) = Int -> (Int -> Magma Int b b a) -> Mafic a b b
forall a b t. Int -> (Int -> Magma Int t b a) -> Mafic a b t
Mafic Int
w ((a -> b) -> Magma Int a b a -> Magma Int b b a
forall x y i b a. (x -> y) -> Magma i x b a -> Magma i y b a
MagmaFmap a -> b
f (Magma Int a b a -> Magma Int b b a)
-> (Int -> Magma Int a b a) -> Int -> Magma Int b b a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Magma Int a b a
k)
  {-# INLINE fmap #-}

instance Apply (Mafic a b) where
  Mafic wf :: Int
wf mf :: Int -> Magma Int (a -> b) b a
mf <.> :: Mafic a b (a -> b) -> Mafic a b a -> Mafic a b b
<.> ~(Mafic wa :: Int
wa ma :: Int -> Magma Int a b a
ma) = Int -> (Int -> Magma Int b b a) -> Mafic a b b
forall a b t. Int -> (Int -> Magma Int t b a) -> Mafic a b t
Mafic (Int
wf Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wa) ((Int -> Magma Int b b a) -> Mafic a b b)
-> (Int -> Magma Int b b a) -> Mafic a b b
forall a b. (a -> b) -> a -> b
$ \o :: Int
o -> Magma Int (a -> b) b a -> Magma Int a b a -> Magma Int b b a
forall i x y b a.
Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a
MagmaAp (Int -> Magma Int (a -> b) b a
mf Int
o) (Int -> Magma Int a b a
ma (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wf))
  {-# INLINE (<.>) #-}

instance Applicative (Mafic a b) where
  pure :: a -> Mafic a b a
pure a :: a
a = Int -> (Int -> Magma Int a b a) -> Mafic a b a
forall a b t. Int -> (Int -> Magma Int t b a) -> Mafic a b t
Mafic 0 ((Int -> Magma Int a b a) -> Mafic a b a)
-> (Int -> Magma Int a b a) -> Mafic a b a
forall a b. (a -> b) -> a -> b
$ \_ -> a -> Magma Int a b a
forall x i b a. x -> Magma i x b a
MagmaPure a
a
  {-# INLINE pure #-}
  Mafic wf :: Int
wf mf :: Int -> Magma Int (a -> b) b a
mf <*> :: Mafic a b (a -> b) -> Mafic a b a -> Mafic a b b
<*> ~(Mafic wa :: Int
wa ma :: Int -> Magma Int a b a
ma) = Int -> (Int -> Magma Int b b a) -> Mafic a b b
forall a b t. Int -> (Int -> Magma Int t b a) -> Mafic a b t
Mafic (Int
wf Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wa) ((Int -> Magma Int b b a) -> Mafic a b b)
-> (Int -> Magma Int b b a) -> Mafic a b b
forall a b. (a -> b) -> a -> b
$ \o :: Int
o -> Magma Int (a -> b) b a -> Magma Int a b a -> Magma Int b b a
forall i x y b a.
Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a
MagmaAp (Int -> Magma Int (a -> b) b a
mf Int
o) (Int -> Magma Int a b a
ma (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wf))
  {-# INLINE (<*>) #-}

instance Sellable (->) Mafic where
  sell :: a -> Mafic a b b
sell a :: a
a = Int -> (Int -> Magma Int b b a) -> Mafic a b b
forall a b t. Int -> (Int -> Magma Int t b a) -> Mafic a b t
Mafic 1 ((Int -> Magma Int b b a) -> Mafic a b b)
-> (Int -> Magma Int b b a) -> Mafic a b b
forall a b. (a -> b) -> a -> b
$ \ i :: Int
i -> Int -> a -> Magma Int b b a
forall i a b. i -> a -> Magma i b b a
Magma Int
i a
a
  {-# INLINE sell #-}

instance Bizarre (Indexed Int) Mafic where
  bazaar :: Indexed Int a (f b) -> Mafic a b t -> f t
bazaar (Indexed Int a (f b)
pafb :: Indexed Int a (f b)) (Mafic _ k :: Int -> Magma Int t b a
k) = Magma Int t b a -> f t
forall t. Magma Int t b a -> f t
go (Int -> Magma Int t b a
k 0) where
    go :: Magma Int t b a -> f t
    go :: Magma Int t b a -> f t
go (MagmaAp x :: Magma Int (x -> t) b a
x y :: Magma Int x b a
y)   = Magma Int (x -> t) b a -> f (x -> t)
forall t. Magma Int t b a -> f t
go Magma Int (x -> t) b a
x f (x -> t) -> f x -> f t
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Magma Int x b a -> f x
forall t. Magma Int t b a -> f t
go Magma Int x b a
y
    go (MagmaFmap f :: x -> t
f x :: Magma Int x b a
x) = x -> t
f (x -> t) -> f x -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Magma Int x b a -> f x
forall t. Magma Int t b a -> f t
go Magma Int x b a
x
    go (MagmaPure x :: t
x)   = t -> f t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
x
    go (Magma i :: Int
i a :: a
a) = Indexed Int a (f b) -> Int -> a -> f b
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed Indexed Int a (f b)
pafb (Int
i :: Int) a
a
  {-# INLINE bazaar #-}

instance IndexedFunctor Mafic where
  ifmap :: (s -> t) -> Mafic a b s -> Mafic a b t
ifmap f :: s -> t
f (Mafic w :: Int
w k :: Int -> Magma Int s b a
k) = Int -> (Int -> Magma Int t b a) -> Mafic a b t
forall a b t. Int -> (Int -> Magma Int t b a) -> Mafic a b t
Mafic Int
w ((s -> t) -> Magma Int s b a -> Magma Int t b a
forall x y i b a. (x -> y) -> Magma i x b a -> Magma i y b a
MagmaFmap s -> t
f (Magma Int s b a -> Magma Int t b a)
-> (Int -> Magma Int s b a) -> Int -> Magma Int t b a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Magma Int s b a
k)
  {-# INLINE ifmap #-}

------------------------------------------------------------------------------
-- TakingWhile
------------------------------------------------------------------------------

-- | This is used to generate an indexed magma from an unindexed source
--
-- By constructing it this way we avoid infinite reassociations where possible.
--
-- In @'TakingWhile' p g a b t@, @g@ has a @nominal@ role to avoid exposing an illegal _|_ via 'Contravariant',
-- while the remaining arguments are degraded to a @nominal@ role by the invariants of 'Magma'
data TakingWhile p (g :: * -> *) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a))
#if __GLASGOW_HASKELL__ >= 707
type role TakingWhile nominal nominal nominal nominal nominal
#endif

-- | Generate a 'Magma' with leaves only while the predicate holds from left to right.
runTakingWhile :: TakingWhile p f a b t -> Magma () t b (Corep p a)
runTakingWhile :: TakingWhile p f a b t -> Magma () t b (Corep p a)
runTakingWhile (TakingWhile _ _ k :: Bool -> Magma () t b (Corep p a)
k) = Bool -> Magma () t b (Corep p a)
k Bool
True

instance Functor (TakingWhile p f a b) where
  fmap :: (a -> b) -> TakingWhile p f a b a -> TakingWhile p f a b b
fmap f :: a -> b
f (TakingWhile w :: Bool
w t :: a
t k :: Bool -> Magma () a b (Corep p a)
k) = let ft :: b
ft = a -> b
f a
t in Bool
-> b -> (Bool -> Magma () b b (Corep p a)) -> TakingWhile p f a b b
forall (p :: * -> * -> *) (g :: * -> *) a b t.
Bool
-> t -> (Bool -> Magma () t b (Corep p a)) -> TakingWhile p g a b t
TakingWhile Bool
w b
ft ((Bool -> Magma () b b (Corep p a)) -> TakingWhile p f a b b)
-> (Bool -> Magma () b b (Corep p a)) -> TakingWhile p f a b b
forall a b. (a -> b) -> a -> b
$ \b :: Bool
b -> if Bool
b then (a -> b) -> Magma () a b (Corep p a) -> Magma () b b (Corep p a)
forall x y i b a. (x -> y) -> Magma i x b a -> Magma i y b a
MagmaFmap a -> b
f (Bool -> Magma () a b (Corep p a)
k Bool
b) else b -> Magma () b b (Corep p a)
forall x i b a. x -> Magma i x b a
MagmaPure b
ft
  {-# INLINE fmap #-}

instance Apply (TakingWhile p f a b) where
  TakingWhile wf :: Bool
wf tf :: a -> b
tf mf :: Bool -> Magma () (a -> b) b (Corep p a)
mf <.> :: TakingWhile p f a b (a -> b)
-> TakingWhile p f a b a -> TakingWhile p f a b b
<.> ~(TakingWhile wa :: Bool
wa ta :: a
ta ma :: Bool -> Magma () a b (Corep p a)
ma) = Bool
-> b -> (Bool -> Magma () b b (Corep p a)) -> TakingWhile p f a b b
forall (p :: * -> * -> *) (g :: * -> *) a b t.
Bool
-> t -> (Bool -> Magma () t b (Corep p a)) -> TakingWhile p g a b t
TakingWhile (Bool
wf Bool -> Bool -> Bool
&& Bool
wa) (a -> b
tf a
ta) ((Bool -> Magma () b b (Corep p a)) -> TakingWhile p f a b b)
-> (Bool -> Magma () b b (Corep p a)) -> TakingWhile p f a b b
forall a b. (a -> b) -> a -> b
$ \o :: Bool
o ->
    if Bool
o then Magma () (a -> b) b (Corep p a)
-> Magma () a b (Corep p a) -> Magma () b b (Corep p a)
forall i x y b a.
Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a
MagmaAp (Bool -> Magma () (a -> b) b (Corep p a)
mf Bool
True) (Bool -> Magma () a b (Corep p a)
ma Bool
wf) else b -> Magma () b b (Corep p a)
forall x i b a. x -> Magma i x b a
MagmaPure (a -> b
tf a
ta)
  {-# INLINE (<.>) #-}

instance Applicative (TakingWhile p f a b) where
  pure :: a -> TakingWhile p f a b a
pure a :: a
a = Bool
-> a -> (Bool -> Magma () a b (Corep p a)) -> TakingWhile p f a b a
forall (p :: * -> * -> *) (g :: * -> *) a b t.
Bool
-> t -> (Bool -> Magma () t b (Corep p a)) -> TakingWhile p g a b t
TakingWhile Bool
True a
a ((Bool -> Magma () a b (Corep p a)) -> TakingWhile p f a b a)
-> (Bool -> Magma () a b (Corep p a)) -> TakingWhile p f a b a
forall a b. (a -> b) -> a -> b
$ \_ -> a -> Magma () a b (Corep p a)
forall x i b a. x -> Magma i x b a
MagmaPure a
a
  {-# INLINE pure #-}
  TakingWhile wf :: Bool
wf tf :: a -> b
tf mf :: Bool -> Magma () (a -> b) b (Corep p a)
mf <*> :: TakingWhile p f a b (a -> b)
-> TakingWhile p f a b a -> TakingWhile p f a b b
<*> ~(TakingWhile wa :: Bool
wa ta :: a
ta ma :: Bool -> Magma () a b (Corep p a)
ma) = Bool
-> b -> (Bool -> Magma () b b (Corep p a)) -> TakingWhile p f a b b
forall (p :: * -> * -> *) (g :: * -> *) a b t.
Bool
-> t -> (Bool -> Magma () t b (Corep p a)) -> TakingWhile p g a b t
TakingWhile (Bool
wf Bool -> Bool -> Bool
&& Bool
wa) (a -> b
tf a
ta) ((Bool -> Magma () b b (Corep p a)) -> TakingWhile p f a b b)
-> (Bool -> Magma () b b (Corep p a)) -> TakingWhile p f a b b
forall a b. (a -> b) -> a -> b
$ \o :: Bool
o ->
    if Bool
o then Magma () (a -> b) b (Corep p a)
-> Magma () a b (Corep p a) -> Magma () b b (Corep p a)
forall i x y b a.
Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a
MagmaAp (Bool -> Magma () (a -> b) b (Corep p a)
mf Bool
True) (Bool -> Magma () a b (Corep p a)
ma Bool
wf) else b -> Magma () b b (Corep p a)
forall x i b a. x -> Magma i x b a
MagmaPure (a -> b
tf a
ta)
  {-# INLINE (<*>) #-}

instance Corepresentable p => Bizarre p (TakingWhile p g) where
  bazaar :: p a (f b) -> TakingWhile p g a b t -> f t
bazaar (p a (f b)
pafb :: p a (f b)) ~(TakingWhile _ _ k :: Bool -> Magma () t b (Corep p a)
k) = Magma () t b (Corep p a) -> f t
forall t. Magma () t b (Corep p a) -> f t
go (Bool -> Magma () t b (Corep p a)
k Bool
True) where
    go :: Magma () t b (Corep p a) -> f t
    go :: Magma () t b (Corep p a) -> f t
go (MagmaAp x :: Magma () (x -> t) b (Corep p a)
x y :: Magma () x b (Corep p a)
y)  = Magma () (x -> t) b (Corep p a) -> f (x -> t)
forall t. Magma () t b (Corep p a) -> f t
go Magma () (x -> t) b (Corep p a)
x f (x -> t) -> f x -> f t
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Magma () x b (Corep p a) -> f x
forall t. Magma () t b (Corep p a) -> f t
go Magma () x b (Corep p a)
y
    go (MagmaFmap f :: x -> t
f x :: Magma () x b (Corep p a)
x)  = x -> t
f (x -> t) -> f x -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Magma () x b (Corep p a) -> f x
forall t. Magma () t b (Corep p a) -> f t
go Magma () x b (Corep p a)
x
    go (MagmaPure x :: t
x)    = t -> f t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
x
    go (Magma _ wa :: Corep p a
wa) = p a (f b) -> Corep p a -> f b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve p a (f b)
pafb Corep p a
wa
  {-# INLINE bazaar #-}

-- This constraint is unused intentionally, it protects TakingWhile
instance Contravariant f => Contravariant (TakingWhile p f a b) where
  contramap :: (a -> b) -> TakingWhile p f a b b -> TakingWhile p f a b a
contramap _ = a -> TakingWhile p f a b b -> TakingWhile p f a b a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
(<$) (String -> a
forall a. HasCallStack => String -> a
error "contramap: TakingWhile")
  {-# INLINE contramap #-}

instance IndexedFunctor (TakingWhile p f) where
  ifmap :: (s -> t) -> TakingWhile p f a b s -> TakingWhile p f a b t
ifmap = (s -> t) -> TakingWhile p f a b s -> TakingWhile p f a b t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
  {-# INLINE ifmap #-}