EitherS.hs

{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module EitherS
  ( EitherS(EitherS)
  , runEitherS ) where

import Control.Applicative (Alternative, empty, (<|>))
import Data.Bifunctor (first)


newtype EitherS a b = EitherS { runEitherS :: Either a b }
  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

instance Semigroup a => Applicative (EitherS a) where
  pure = EitherS . pure
  (EitherS (Right f)) <*> (EitherS (Right x)) = EitherS (Right (f x))
  (EitherS (Left x)) <*> (EitherS (Right _)) = EitherS (Left x)
  (EitherS (Right _)) <*> (EitherS (Left y)) = EitherS (Left y)
  (EitherS (Left x)) <*> (EitherS (Left y)) = EitherS (Left (x <> y))

instance (Semigroup a, Semigroup b) => Semigroup (EitherS a b) where
  x <> y = (<>) <$> x <*> y

instance (Semigroup a, Monoid b) => Monoid (EitherS a b) where
  mempty = pure mempty

newtype FirstVal a = FirstVal { getFirstVal :: a }
instance Semigroup (FirstVal a) where
  (<>) = const

instance (Monoid a) => Alternative (EitherS a) where
  empty = EitherS (Left mempty)
  x <|> y = getFirstVal <$> flipEitherS (flipEitherS (FirstVal <$> x) <> flipEitherS (FirstVal <$> y))
    where
      flipEitherS (EitherS (Left x)) = EitherS (Right x)
      flipEitherS (EitherS (Right x)) = EitherS (Left x)