module Data.FMList (
FMList(..)
, transform
, empty
, singleton
, cons
, snoc
, append
, toList
, fromList
, fromFoldable
, null
, length
, genericLength
, head
, tail
, last
, init
, reverse
, flatten
, filter
, take
, drop
, takeWhile
, dropWhile
, zip
, zipWith
, iterate
, repeat
, unfoldr
, unfoldl
) where
import Prelude
( (.), ($), ($!), flip, const, id, error
, Maybe(..), maybe
, Bool(..), (||), not
, Ord(..), Num(..), Int
, Show(..), String, (++)
)
import qualified Data.List as List
import Data.Monoid
import Data.Foldable
import Data.Traversable
import Control.Monad
import Control.Applicative
newtype FMList a = FM { unFM :: forall b . Monoid b => (a -> b) -> b }
transform :: (forall b. Monoid b => (a -> b) -> (c -> b)) -> FMList c -> FMList a
transform t l = FM $ \f -> unFM l (t f)
nil :: FMList a
nil = FM $ \_ -> mempty
singleton :: a -> FMList a
singleton x = FM $ \f -> f x
cons :: a -> FMList a -> FMList a
cons x l = FM $ \f -> f x `mappend` unFM l f
snoc :: FMList a -> a -> FMList a
snoc l x = FM $ \f -> unFM l f `mappend` f x
append :: FMList a -> FMList a -> FMList a
append l r = FM $ unFM l `mappend` unFM r
fromList :: [a] -> FMList a
fromList = fromFoldable
fromFoldable :: Foldable f => f a -> FMList a
fromFoldable l = FM $ flip foldMap l
null :: FMList a -> Bool
null = foldr (\_ _ -> False) True
length :: FMList a -> Int
length = genericLength
genericLength :: Num b => FMList a -> b
genericLength l = getSum $ unFM l (const $ Sum 1)
head :: FMList a -> a
head l = getFirst (unFM l (First . Just)) `fromJustOrError` "Data.FMList.head: empty list"
tail :: FMList a -> FMList a
tail l = if null l then error "Data.FMList.tail: empty list" else drop (1::Int) l
last :: FMList a -> a
last l = getLast (unFM l (Last . Just)) `fromJustOrError` "Data.FMList.last: empty list"
init :: FMList a -> FMList a
init l = if null l then error "Data.FMList.init: empty list" else reverse . drop (1::Int) . reverse $ l
reverse :: FMList a -> FMList a
reverse l = FM $ \f -> getDual $ unFM l (Dual . f)
flatten :: FMList (FMList a) -> FMList a
flatten = transform foldMap
filter :: (a -> Bool) -> FMList a -> FMList a
filter p = transform (\f e -> if p e then f e else mempty)
take :: (Ord n, Num n) => n -> FMList a -> FMList a
take n l = FM $ \f ->
foldr (\e r i -> if i > 0 then mappend (f e) (r (i1)) else mempty) (const mempty) l n
drop :: (Ord n, Num n) => n -> FMList a -> FMList a
drop n l = FM $ \f ->
foldr (\e r i -> if i <= 0 then mappend (f e) (r i) else r (i1)) (const mempty) l n
takeWhile :: (a -> Bool) -> FMList a -> FMList a
takeWhile p l = FM $ \f ->
foldr (\e r -> if p e then mappend (f e) r else mempty) mempty l
dropWhile :: (a -> Bool) -> FMList a -> FMList a
dropWhile p l = FM $ \f ->
foldr (\e r done -> if done || not (p e) then mappend (f e) (r True) else r False) (const mempty) l False
zipWith :: (a -> b -> c) -> FMList a -> FMList b -> FMList c
zipWith t l1 l2 = FM $ \f ->
foldr (\e1 r r2 ->
foldr (\e2 _ -> mappend (f (t e1 e2)) (r (drop (1::Int) r2))) mempty r2) (const mempty) l1 l2
zip :: FMList a -> FMList b -> FMList (a,b)
zip = zipWith (,)
iterate :: (a -> a) -> a -> FMList a
iterate f x = x `cons` iterate f (f x)
repeat :: a -> FMList a
repeat x = xs where xs = x `cons` xs
unfoldr :: (b -> Maybe (a, b)) -> b -> FMList a
unfoldr pf b = FM $ \f -> u f mempty (pf b) where
u _ acc Nothing = acc
u f acc (Just (a, b')) = u f (acc `mappend` f a) (pf b')
unfoldl :: (b -> Maybe (b, a)) -> b -> FMList a
unfoldl pf b = FM $ \f -> u f mempty (pf b) where
u _ acc Nothing = acc
u f acc (Just (b', a)) = u f (f a `mappend` acc) (pf b')
instance Functor FMList where
fmap g = transform (. g)
instance Foldable FMList where
foldMap = flip unFM
instance Traversable FMList where
traverse f = foldr cons_f (pure empty) where cons_f x ys = cons <$> f x <*> ys
instance Monad FMList where
return = singleton
m >>= g = transform (\f -> foldMap f . g) m
instance Applicative FMList where
pure = return
gs <*> xs = transform (\f g -> unFM xs (f . g)) gs
instance Monoid (FMList a) where
mempty = nil
mappend = append
instance MonadPlus FMList where
mzero = nil
mplus = append
instance Alternative FMList where
empty = nil
(<|>) = append
instance Show a => Show (FMList a) where
show l = "fromList " ++ (show $! toList l)
fromJustOrError :: Maybe a -> String -> a
fromJustOrError ma e = maybe (error e) id ma