Fair.hs

module Data.List.Fair (Fair (..)) where

import Control.Applicative
import Data.Foldable
import Data.Functor.Classes
import Numeric.Natural
import Util

newtype Fair a = Fair { unFair :: [a] }
  deriving (Functor, Foldable, Traversable, Eq, Ord, Read, Show, Eq1, Ord1, Read1, Show1)

instance Applicative Fair where
    pure a = Fair [a]
    fs <*> xs = fs >>= (<$> xs)

instance Monad Fair where
    Fair xs >>= f = Fair $ [0..] >>= flip diag (unFair . f <$> xs)

diag :: Natural -> [[a]] -> [a]
diag _ [] = []
diag 0 _  = []
diag k (as:ass) = toList (as !!? k) ++ diag (k-1) ass

instance Semigroup a => Semigroup (Fair a) where
    (<>) = liftA2 (<>)

instance Monoid a => Monoid (Fair a) where
    mempty = pure mempty