{-# LANGUAGE TypeFamilies, DeriveFunctor, OverloadedLists #-}
module Tungsten.Structure.List
(
ListF (..), List (..)
, nil, cons
, foldr, map, append
, elem, range
, toList, fromList
)
where
import Data.Functor.Classes
import Prelude hiding (foldr, map, elem, sum)
import qualified Prelude as Prelude
import Data.Coerce (coerce)
import Tungsten.Fix
import GHC.Base (build)
import qualified GHC.Exts as Ext
data ListF a b =
NilF
| ConsF a b
deriving (Eq, Ord, Show, Read, Functor)
instance Eq2 ListF where
liftEq2 _ _ NilF NilF = True
liftEq2 f g (ConsF a b) (ConsF a' b') = f a a' && g b b'
liftEq2 _ _ _ _ = False
instance Eq a => Eq1 (ListF a) where
liftEq = liftEq2 (==)
instance Ord2 ListF where
liftCompare2 _ _ NilF NilF = EQ
liftCompare2 _ _ NilF _ = LT
liftCompare2 _ _ _ NilF = GT
liftCompare2 f g (ConsF a b) (ConsF a' b') = f a a' `mappend` g b b'
instance Ord a => Ord1 (ListF a) where
liftCompare = liftCompare2 compare
instance Show2 ListF where
liftShowsPrec2 sa _ sb _ d x =
case x of
NilF -> showString "NilF"
(ConsF a b) -> showParen (d > 10)
$ showString "ConsF "
. sa 11 a
. showString " "
. sb 11 b
instance Show a => Show1 (ListF a) where
liftShowsPrec = liftShowsPrec2 showsPrec showList
newtype List a = List (Fix (ListF a))
instance Eq a => Eq (List a) where
(List xs) == (List ys) = xs == ys
instance Ord a => Ord (List a) where
compare (List xs) (List ys) = compare xs ys
instance Show a => Show (List a) where
show (List xs) = show xs
instance Functor List where
fmap = map
instance Applicative List where
pure x = cons x nil
fs <*> xs = foldr (\f acc -> foldr (\x -> cons (f x)) acc xs) nil fs
instance Monad List where
return = pure
(>>=) = bind
instance Ext.IsList (List a) where
type (Item (List a)) = a
fromList = fromList
toList = toList
nil :: List a
nil = List (fix NilF)
consF :: (ListF a b -> t) -> a -> b -> t
consF f = \a b -> f (ConsF a b)
cons :: a -> List a -> List a
cons x (List xs) = List (consF fix x xs)
listF :: p -> (t1 -> t2 -> p) -> ListF t1 t2 -> p
listF n _ NilF = n
listF _ c (ConsF a b) = c a b
{-# INLINE listF #-}
foldr :: (a -> b -> b) -> b -> List a -> b
foldr c n = cata (listF n c) . coerce
{-# INLINE foldr #-}
map :: (a -> b) -> List a -> List b
map f xs = coerce $ buildR $ \fix' ->
let go = listF (fix' NilF) (\a -> fix' . ConsF (f a))
in cata go (coerce xs)
{-# INLINE map #-}
append :: List a -> List a -> List a
append (List xs) ys = coerce $ buildR $ \fix' ->
let go = listF (cata fix' (coerce ys)) (consF fix')
in cata go xs
{-# INLINE append #-}
bind :: List a -> (a -> List b) -> List b
bind (List xs) f = List $ buildR $ \fix' ->
let append' (List xs') ys' =
let go = listF ys' (consF fix')
in cata go xs'
go' = listF (fix' NilF) (append' . f)
in cata go' xs
{-# INLINE bind #-}
elem :: Eq a => a -> List a -> Bool
elem e = cata (listF False (\a -> (||) (a == e))) . coerce
{-# INLINE elem #-}
range :: Int -> Int -> List Int
range start end = coerce $ ana go start
where
go n =
if n > end
then NilF
else ConsF n (n+1)
{-# INLINE range #-}
toList :: List a -> [a]
toList xs =
build (\c n -> cata (\x -> listF n c x) (coerce xs))
{-# INLINE toList #-}
fromList :: [a] -> List a
fromList xs = coerce $ buildR $ \fix' -> Prelude.foldr (\x -> fix' . ConsF x) (fix' NilF) xs
{-# INLINE fromList #-}