module Data.FullList.Lazy
( FullList(..)
, List(..)
, size
, singleton
, lookup
, insert
, delete
, insertWith
, adjust
, union
, unionWith
, map
, traverseWithKey
, foldlWithKey'
, foldrWithKey
, filterWithKey
, lookupL
, deleteL
) where
import Control.Applicative
import Control.DeepSeq (NFData(rnf))
import Prelude hiding (lookup, map)
data FullList k v = FL !k v !(List k v)
deriving Show
instance (Eq k, Eq v) => Eq (FullList k v) where
(FL k1 v1 xs) == (FL k2 v2 ys) = k1 == k2 && v1 == v2 && xs == ys
(FL k1 v1 xs) /= (FL k2 v2 ys) = k1 /= k2 || v1 /= v2 || xs /= ys
instance (NFData k, NFData v) => NFData (FullList k v)
data List k v = Nil | Cons !k v !(List k v)
deriving Show
instance (Eq k, Eq v) => Eq (List k v) where
(Cons k1 v1 xs) == (Cons k2 v2 ys) = k1 == k2 && v1 == v2 && xs == ys
Nil == Nil = True
_ == _ = False
(Cons k1 v1 xs) /= (Cons k2 v2 ys) = k1 /= k2 || v1 /= v2 || xs /= ys
Nil /= Nil = False
_ /= _ = True
instance (NFData k, NFData v) => NFData (List k v) where
rnf Nil = ()
rnf (Cons k v xs) = rnf k `seq` rnf v `seq` rnf xs
size :: FullList k v -> Int
size (FL _ _ xs) = 1 + sizeL xs
sizeL :: List k v -> Int
sizeL Nil = 0
sizeL (Cons _ _ xs) = 1 + sizeL xs
singleton :: k -> v -> FullList k v
singleton k v = FL k v Nil
lookup :: Eq k => k -> FullList k v -> Maybe v
lookup !k (FL k' v xs)
| k == k' = Just v
| otherwise = lookupL k xs
#if __GLASGOW_HASKELL__ >= 700
#endif
lookupL :: Eq k => k -> List k v -> Maybe v
lookupL = go
where
go !_ Nil = Nothing
go k (Cons k' v xs)
| k == k' = Just v
| otherwise = go k xs
#if __GLASGOW_HASKELL__ >= 700
#endif
member :: Eq k => k -> FullList k v -> Bool
member !k (FL k' _ xs)
| k == k' = True
| otherwise = memberL k xs
#if __GLASGOW_HASKELL__ >= 700
#endif
memberL :: Eq k => k -> List k v -> Bool
memberL = go
where
go !_ Nil = False
go k (Cons k' _ xs)
| k == k' = True
| otherwise = go k xs
#if __GLASGOW_HASKELL__ >= 700
#endif
insert :: Eq k => k -> v -> FullList k v -> FullList k v
insert !k v (FL k' v' xs)
| k == k' = FL k v xs
| otherwise = FL k' v' (insertL k v xs)
#if __GLASGOW_HASKELL__ >= 700
#endif
insertL :: Eq k => k -> v -> List k v -> List k v
insertL = go
where
go !k v Nil = Cons k v Nil
go k v (Cons k' v' xs)
| k == k' = Cons k v xs
| otherwise = Cons k' v' (go k v xs)
#if __GLASGOW_HASKELL__ >= 700
#endif
delete :: Eq k => k -> FullList k v -> Maybe (FullList k v)
delete !k (FL k' v xs)
| k == k' = case xs of
Nil -> Nothing
Cons k'' v' xs' -> Just $ FL k'' v' xs'
| otherwise = let ys = deleteL k xs
in ys `seq` Just (FL k' v ys)
#if __GLASGOW_HASKELL__ >= 700
#endif
deleteL :: Eq k => k -> List k v -> List k v
deleteL = go
where
go !_ Nil = Nil
go k (Cons k' v xs)
| k == k' = xs
| otherwise = Cons k' v (go k xs)
#if __GLASGOW_HASKELL__ >= 700
#endif
insertWith :: Eq k => (v -> v -> v) -> k -> v -> FullList k v -> FullList k v
insertWith f !k v (FL k' v' xs)
| k == k' = FL k (f v v') xs
| otherwise = FL k' v' (insertWithL f k v xs)
#if __GLASGOW_HASKELL__ >= 700
#endif
insertWithL :: Eq k => (v -> v -> v) -> k -> v -> List k v -> List k v
insertWithL = go
where
go _ !k v Nil = Cons k v Nil
go f k v (Cons k' v' xs)
| k == k' = Cons k (f v v') xs
| otherwise = Cons k' v' (go f k v xs)
#if __GLASGOW_HASKELL__ >= 700
#endif
adjust :: Eq k => (v -> v) -> k -> FullList k v -> FullList k v
adjust f !k (FL k' v xs)
| k == k' = FL k' (f v) xs
| otherwise = FL k' v (adjustL f k xs)
#if __GLASGOW_HASKELL__ >= 700
#endif
adjustL :: Eq k => (v -> v) -> k -> List k v -> List k v
adjustL f = go
where
go !_ Nil = Nil
go k (Cons k' v xs)
| k == k' = Cons k' (f v) xs
| otherwise = Cons k' v (go k xs)
#if __GLASGOW_HASKELL__ >= 700
#endif
union :: Eq k => FullList k v -> FullList k v -> FullList k v
union xs (FL k v ys)
| k `member` xs = unionL xs ys
| otherwise = case unionL xs ys of
FL k' v' zs -> FL k v $ Cons k' v' zs
#if __GLASGOW_HASKELL__ >= 700
#endif
unionL :: Eq k => FullList k v -> List k v -> FullList k v
unionL xs@(FL k v zs) = FL k v . go
where
go Nil = zs
go (Cons k' v' ys)
| k' `member` xs = go ys
| otherwise = Cons k' v' $ go ys
#if __GLASGOW_HASKELL__ >= 700
#endif
unionWith :: Eq k => (v -> v -> v) -> FullList k v -> FullList k v -> FullList k v
unionWith f xs (FL k vy ys) =
case lookup k xs of
Just vx ->
let flCon = FL k (f vx vy)
in case delete k xs of
Nothing -> flCon ys
Just xs' ->
case unionWithL f xs' ys of
FL k' v' zs -> flCon $ Cons k' v' zs
Nothing ->
case unionWithL f xs ys of
FL k' v' zs -> FL k vy $ Cons k' v' zs
#if __GLASGOW_HASKELL__ >= 700
#endif
unionWithL :: Eq k => (v -> v -> v) -> FullList k v -> List k v -> FullList k v
unionWithL f (FL k v zs) ys =
case lookupL k ys of
Just vy -> FL k (f v vy) $ go zs (deleteL k ys)
Nothing -> FL k v (go zs ys)
where
go ws Nil = ws
go ws (Cons k' vy ys') =
case lookupL k' ws of
Just vx -> Cons k' (f vx vy) $ go (deleteL k' ws) ys'
Nothing -> Cons k' vy $ go ws ys'
#if __GLASGOW_HASKELL__ >= 700
#endif
map :: (k1 -> v1 -> (k2, v2)) -> FullList k1 v1 -> FullList k2 v2
map f (FL k v xs) = let (k', v') = f k v
in FL k' v' (mapL f xs)
mapL :: (k1 -> v1 -> (k2, v2)) -> List k1 v1 -> List k2 v2
mapL f = go
where
go Nil = Nil
go (Cons k v xs) = let (k', v') = f k v
in Cons k' v' (go xs)
traverseWithKey :: Applicative m => (k -> v1 -> m v2) -> FullList k v1 -> m (FullList k v2)
traverseWithKey f (FL k v xs) = FL k <$> f k v <*> traverseWithKeyL f xs
traverseWithKeyL :: Applicative m => (k -> v1 -> m v2) -> List k v1 -> m (List k v2)
traverseWithKeyL f = go
where
go Nil = pure Nil
go (Cons k v xs) = Cons k <$> f k v <*> go xs
foldlWithKey' :: (a -> k -> v -> a) -> a -> FullList k v -> a
foldlWithKey' f !z (FL k v xs) = foldlWithKey'L f (f z k v) xs
foldlWithKey'L :: (a -> k -> v -> a) -> a -> List k v -> a
foldlWithKey'L f = go
where
go !z Nil = z
go z (Cons k v xs) = go (f z k v) xs
foldrWithKey :: (k -> v -> a -> a) -> a -> FullList k v -> a
foldrWithKey f z (FL k v xs) = f k v (foldrWithKeyL f z xs)
foldrWithKeyL :: (k -> v -> a -> a) -> a -> List k v -> a
foldrWithKeyL f = go
where
go z Nil = z
go z (Cons k v xs) = f k v (go z xs)
filterWithKey :: (k -> v -> Bool) -> FullList k v -> Maybe (FullList k v)
filterWithKey p (FL k v xs)
| p k v = Just (FL k v ys)
| otherwise = case ys of
Nil -> Nothing
Cons k' v' zs -> Just $ FL k' v' zs
where !ys = filterWithKeyL p xs
filterWithKeyL :: (k -> v -> Bool) -> List k v -> List k v
filterWithKeyL p = go
where
go Nil = Nil
go (Cons k v xs)
| p k v = Cons k v (go xs)
| otherwise = go xs