Fork1.hs

{-# 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 { runFork1 :: forall r . (r -> r -> r) -> (a -> r) -> r }

instance Show a => Show (Fork1 a) where
  showsPrec _ = showList . toList

instance Semigroup (Fork1 a) where
  Fork1 a1 <> Fork1 a2 = Fork1 (\ (<>) singleton -> a1 (<>) singleton <> a2 (<>) singleton)

instance Foldable Fork1 where
  foldMap = foldMap1

instance Foldable1 Fork1 where
  foldMap1 f (Fork1 r) = r (<>) f

instance Functor Fork1 where
  fmap f (Fork1 r) = Fork1 (\ (<>) singleton -> r (<>) (singleton . f))

instance Traversable Fork1 where
  traverse f (Fork1 r) = r ((<*>) . fmap (<>)) (fmap singleton . f)

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

instance Applicative Fork1 where
  pure = singleton

  (<*>) = (<.>)

instance Alt Fork1 where
  (<!>) = (<>)


-- Construction

singleton :: a -> Fork1 a
singleton a = Fork1 (\ _ singleton -> singleton a)