{-# LANGUAGE RankNTypes #-}
module Fresnel.Monoid.Fork
( -- * Binary trees
  Fork(..)
  -- * Construction
, singleton
) where

import Control.Applicative (Alternative(..))
import Data.Foldable (toList)

-- Binary trees

newtype Fork a = Fork { forall a. Fork a -> forall r. (r -> r -> r) -> (a -> r) -> r -> r
runFork :: forall r . (r -> r -> r) -> (a -> r) -> r -> r }

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

instance Semigroup (Fork a) where
  Fork forall r. (r -> r -> r) -> (a -> r) -> r -> r
a1 <> :: Fork a -> Fork a -> Fork a
<> Fork forall r. (r -> r -> r) -> (a -> r) -> r -> r
a2 = (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> Fork a
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> Fork a
Fork (\ r -> r -> r
fork a -> r
leaf r
nil -> (r -> r -> r) -> (a -> r) -> r -> r
forall r. (r -> r -> r) -> (a -> r) -> r -> r
a1 r -> r -> r
fork a -> r
leaf r
nil r -> r -> r
`fork` (r -> r -> r) -> (a -> r) -> r -> r
forall r. (r -> r -> r) -> (a -> r) -> r -> r
a2 r -> r -> r
fork a -> r
leaf r
nil)

instance Monoid (Fork a) where
  mempty :: Fork a
mempty = (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> Fork a
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> Fork a
Fork (\ r -> r -> r
_ a -> r
_ r
nil -> r
nil)

instance Foldable Fork where
  foldMap :: forall m a. Monoid m => (a -> m) -> Fork a -> m
foldMap a -> m
f (Fork forall r. (r -> r -> r) -> (a -> r) -> r -> r
r) = (m -> m -> m) -> (a -> m) -> m -> m
forall r. (r -> r -> r) -> (a -> r) -> r -> r
r m -> m -> m
forall a. Semigroup a => a -> a -> a
(<>) a -> m
f m
forall a. Monoid a => a
mempty

instance Functor Fork where
  fmap :: forall a b. (a -> b) -> Fork a -> Fork b
fmap a -> b
f (Fork forall r. (r -> r -> r) -> (a -> r) -> r -> r
r) = (forall r. (r -> r -> r) -> (b -> r) -> r -> r) -> Fork b
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> Fork a
Fork (\ r -> r -> r
fork b -> r
leaf -> (r -> r -> r) -> (a -> r) -> r -> r
forall r. (r -> r -> r) -> (a -> r) -> r -> r
r r -> r -> r
fork (b -> r
leaf (b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))

instance Applicative Fork where
  pure :: forall a. a -> Fork a
pure a
a = (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> Fork a
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> Fork a
Fork (\ r -> r -> r
_ a -> r
leaf r
_ -> a -> r
leaf a
a)
  Fork forall r. (r -> r -> r) -> ((a -> b) -> r) -> r -> r
f <*> :: forall a b. Fork (a -> b) -> Fork a -> Fork b
<*> Fork forall r. (r -> r -> r) -> (a -> r) -> r -> r
a = (forall r. (r -> r -> r) -> (b -> r) -> r -> r) -> Fork b
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> Fork a
Fork (\ r -> r -> r
fork b -> r
leaf r
nil -> (r -> r -> r) -> ((a -> b) -> r) -> r -> r
forall r. (r -> r -> r) -> ((a -> b) -> r) -> r -> r
f r -> r -> r
fork (\ a -> b
f' -> (r -> r -> r) -> (a -> r) -> r -> r
forall r. (r -> r -> r) -> (a -> r) -> r -> r
a r -> r -> r
fork (b -> r
leaf (b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f') r
nil) r
nil)

instance Alternative Fork where
  empty :: forall a. Fork a
empty = Fork a
forall a. Monoid a => a
mempty
  <|> :: forall a. Fork a -> Fork a -> Fork a
(<|>) = Fork a -> Fork a -> Fork a
forall a. Semigroup a => a -> a -> a
(<>)


-- Construction

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