{-# LANGUAGE RankNTypes #-}
module Fresnel.Semigroup.Fork1
( -- * Non-empty binary trees
  Fork1(..)
  -- * Construction
, singleton
) where

import Data.Foldable (toList)
import Data.Foldable1
import Data.Functor.Alt

-- Non-empty binary trees

newtype Fork1 a = Fork1 { forall a. Fork1 a -> forall r. (r -> r -> r) -> (a -> r) -> r
runFork1 :: forall r . (r -> r -> r) -> (a -> r) -> r }

instance Show a => Show (Fork1 a) where
  showsPrec :: Int -> Fork1 a -> ShowS
showsPrec Int
_ = [a] -> ShowS
forall a. Show a => [a] -> ShowS
showList ([a] -> ShowS) -> (Fork1 a -> [a]) -> Fork1 a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fork1 a -> [a]
forall a. Fork1 a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance Semigroup (Fork1 a) where
  Fork1 forall r. (r -> r -> r) -> (a -> r) -> r
a1 <> :: Fork1 a -> Fork1 a -> Fork1 a
<> Fork1 forall r. (r -> r -> r) -> (a -> r) -> r
a2 = (forall r. (r -> r -> r) -> (a -> r) -> r) -> Fork1 a
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r) -> Fork1 a
Fork1 (\ r -> r -> r
(<>) a -> r
singleton -> (r -> r -> r) -> (a -> r) -> r
forall r. (r -> r -> r) -> (a -> r) -> r
a1 r -> r -> r
(<>) a -> r
singleton r -> r -> r
<> (r -> r -> r) -> (a -> r) -> r
forall r. (r -> r -> r) -> (a -> r) -> r
a2 r -> r -> r
(<>) a -> r
singleton)

instance Foldable Fork1 where
  foldMap :: forall m a. Monoid m => (a -> m) -> Fork1 a -> m
foldMap = (a -> m) -> Fork1 a -> m
forall m a. Semigroup m => (a -> m) -> Fork1 a -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1

instance Foldable1 Fork1 where
  foldMap1 :: forall m a. Semigroup m => (a -> m) -> Fork1 a -> m
foldMap1 a -> m
f (Fork1 forall r. (r -> r -> r) -> (a -> r) -> r
r) = (m -> m -> m) -> (a -> m) -> m
forall r. (r -> r -> r) -> (a -> r) -> r
r m -> m -> m
forall a. Semigroup a => a -> a -> a
(<>) a -> m
f

instance Functor Fork1 where
  fmap :: forall a b. (a -> b) -> Fork1 a -> Fork1 b
fmap a -> b
f (Fork1 forall r. (r -> r -> r) -> (a -> r) -> r
r) = (forall r. (r -> r -> r) -> (b -> r) -> r) -> Fork1 b
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r) -> Fork1 a
Fork1 (\ r -> r -> r
(<>) b -> r
singleton -> (r -> r -> r) -> (a -> r) -> r
forall r. (r -> r -> r) -> (a -> r) -> r
r r -> r -> r
(<>) (b -> r
singleton (b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))

instance Traversable Fork1 where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Fork1 a -> f (Fork1 b)
traverse a -> f b
f (Fork1 forall r. (r -> r -> r) -> (a -> r) -> r
r) = (f (Fork1 b) -> f (Fork1 b) -> f (Fork1 b))
-> (a -> f (Fork1 b)) -> f (Fork1 b)
forall r. (r -> r -> r) -> (a -> r) -> r
r (f (Fork1 b -> Fork1 b) -> f (Fork1 b) -> f (Fork1 b)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (f (Fork1 b -> Fork1 b) -> f (Fork1 b) -> f (Fork1 b))
-> (f (Fork1 b) -> f (Fork1 b -> Fork1 b))
-> f (Fork1 b)
-> f (Fork1 b)
-> f (Fork1 b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fork1 b -> Fork1 b -> Fork1 b)
-> f (Fork1 b) -> f (Fork1 b -> Fork1 b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fork1 b -> Fork1 b -> Fork1 b
forall a. Semigroup a => a -> a -> a
(<>)) ((b -> Fork1 b) -> f b -> f (Fork1 b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Fork1 b
forall a. a -> Fork1 a
singleton (f b -> f (Fork1 b)) -> (a -> f b) -> a -> f (Fork1 b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f)

instance Apply Fork1 where
  liftF2 :: forall a b c. (a -> b -> c) -> Fork1 a -> Fork1 b -> Fork1 c
liftF2 a -> b -> c
f (Fork1 forall r. (r -> r -> r) -> (a -> r) -> r
a) (Fork1 forall r. (r -> r -> r) -> (b -> r) -> r
b) = (forall r. (r -> r -> r) -> (c -> r) -> r) -> Fork1 c
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r) -> Fork1 a
Fork1 (\ r -> r -> r
(<>) c -> r
singleton -> (r -> r -> r) -> (a -> r) -> r
forall r. (r -> r -> r) -> (a -> r) -> r
a r -> r -> r
(<>) (\ a
a' -> (r -> r -> r) -> (b -> r) -> r
forall r. (r -> r -> r) -> (b -> r) -> r
b r -> r -> r
(<>) (c -> r
singleton (c -> r) -> (b -> c) -> b -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c
f a
a')))

instance Applicative Fork1 where
  pure :: forall a. a -> Fork1 a
pure = a -> Fork1 a
forall a. a -> Fork1 a
singleton

  <*> :: forall a b. Fork1 (a -> b) -> Fork1 a -> Fork1 b
(<*>) = Fork1 (a -> b) -> Fork1 a -> Fork1 b
forall a b. Fork1 (a -> b) -> Fork1 a -> Fork1 b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
(<.>)

instance Alt Fork1 where
  <!> :: forall a. Fork1 a -> Fork1 a -> Fork1 a
(<!>) = Fork1 a -> Fork1 a -> Fork1 a
forall a. Semigroup a => a -> a -> a
(<>)


-- Construction

singleton :: a -> Fork1 a
singleton :: forall a. a -> Fork1 a
singleton a
a = (forall r. (r -> r -> r) -> (a -> r) -> r) -> Fork1 a
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r) -> Fork1 a
Fork1 (\ r -> r -> r
_ a -> r
singleton -> a -> r
singleton a
a)