FList.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}

module FList
  ( FList
  ) where

import GHC.Exts

data FList a where
  Empty :: FList a
  Singleton :: a -> FList a
  Cons :: a -> FList a -> FList a
  Snoc :: FList a -> a -> FList a
  Append :: FList a -> FList a -> FList a
  FromList :: [a] -> FList a
  Map :: (a -> b) -> FList a -> FList b
  Join :: FList (FList a) -> FList a

instance Semigroup (FList a) where
  {-# INLINE (<>) #-}
  (<>) = Append

instance Monoid (FList a) where
  {-# INLINE mempty #-}
  mempty = Empty

instance Foldable FList where
  foldr f b l =
    case l of
      Empty -> b
      Singleton a -> f a b
      Cons a l0 -> f a (foldr f b l0)
      Snoc l0 a -> foldr f (f a b) l0
      Append l0 l1 -> foldr f (foldr f b l1) l0
      FromList l0 -> Prelude.foldr f b l0
      Map g l0 -> foldr (f . g) b l0
      Join l0 -> foldr (flip (foldr f)) b l0

instance Functor FList where
  {-# INLINE fmap #-}
  fmap = Map

instance Applicative FList where
  {-# INLINE pure #-}
  pure = Singleton
  {-# INLINE (<*>) #-}
  f <*> a = Join (Map (flip Map a) f)

instance Monad FList where
  {-# INLINE (>>=) #-}
  l >>= f = Join (Map f l)

instance IsList (FList a) where
  type Item (FList a) = a
  {-# INLINE fromList #-}
  fromList = FromList
  {-# INLINE toList #-}
  toList = foldr (:) []

instance Show a => Show (FList a) where
  {-# INLINE showsPrec #-}
  showsPrec i = showsPrec i . toList