module Jukebox.Seq where
import Prelude hiding (concat, concatMap, length, mapM, mapM_)
import Control.Monad hiding (mapM, mapM_)
import Data.Hashable
import qualified Data.HashSet as Set
import Data.Monoid
import Control.Applicative
data Seq a = Append (Seq a) (Seq a) | Unit a | Nil
class List f where
fromList :: f a -> Seq a
toList :: f a -> [a]
instance List [] where
fromList = foldr cons Nil
toList = id
instance List Seq where
fromList = id
toList x = go [x]
where go (Nil:left) = go left
go (Unit x:left) = x:go left
go (Append x y:left) = go (x:y:left)
go [] = []
appendA :: Seq a -> Seq a -> Seq a
appendA Nil xs = xs
appendA xs Nil = xs
appendA xs ys = Append xs ys
instance Show a => Show (Seq a) where
show = show . toList
cons :: a -> Seq a -> Seq a
cons x xs = Unit x `appendA` xs
snoc :: Seq a -> a -> Seq a
snoc xs x = xs `appendA` Unit x
append :: (List f, List g) => f a -> g a -> Seq a
append xs ys = fromList xs `appendA` fromList ys
instance Functor Seq where
fmap f (Append x y) = Append (fmap f x) (fmap f y)
fmap f (Unit x) = Unit (f x)
fmap f Nil = Nil
instance Applicative Seq where
pure = return
(<*>) = liftM2 ($)
instance Monad Seq where
return = Unit
x >>= f = concatMapA f x
fail _ = Nil
instance Alternative Seq where
empty = mzero
(<|>) = mplus
instance MonadPlus Seq where
mzero = Nil
mplus = append
instance Monoid (Seq a) where
mempty = Nil
mappend = append
concat :: (List f, List g) => f (g a) -> Seq a
concat = concatMap id
concatMap :: (List f, List g) => (a -> g b) -> f a -> Seq b
concatMap f xs = concatMapA (fromList . f) (fromList xs)
concatMapA :: (a -> Seq b) -> Seq a -> Seq b
concatMapA f = aux
where aux (Append x y) = aux x `appendA` aux y
aux (Unit x) = f x
aux Nil = Nil
fold :: (b -> b -> b) -> (a -> b) -> b -> Seq a -> b
fold app u n (Append x y) = app (fold app u n x) (fold app u n y)
fold app u n (Unit x) = u x
fold app u n Nil = n
unique :: (Ord a, Hashable a, List f) => f a -> [a]
unique = Set.toList . Set.fromList . toList . fromList
length :: Seq a -> Int
length Nil = 0
length (Unit _) = 1
length (Append x y) = length x + length y
mapM :: Monad m => (a -> m b) -> Seq a -> m (Seq b)
mapM f Nil = return Nil
mapM f (Unit x) = liftM Unit (f x)
mapM f (Append x y) = liftM2 Append (mapM f x) (mapM f y)
mapM_ :: Monad m => (a -> m ()) -> Seq a -> m ()
mapM_ f Nil = return ()
mapM_ f (Unit x) = f x
mapM_ f (Append x y) = mapM_ f x >> mapM_ f y
sequence :: Monad m => Seq (m a) -> m (Seq a)
sequence = mapM id