108 lines
3.2 KiB
Haskell
108 lines
3.2 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
module FoldableHelp
|
|
( safeMinimumOn
|
|
, safeMinimumOnMaybe
|
|
, safeMinimumOnMaybeF
|
|
, safeMinimumOnMaybeL
|
|
, safeMinMaybeL
|
|
, filter3
|
|
, takeUntil
|
|
, ssfold
|
|
, minOn
|
|
, module Data.Foldable
|
|
)
|
|
where
|
|
import Data.Foldable
|
|
|
|
import qualified Control.Foldl as L
|
|
|
|
-- TODO check up whether and how it is necessary to specialise this
|
|
-- | A version of 'minimum' where the comparison is done on some extracted value.
|
|
-- Returns Nothing if the list is empty.
|
|
--
|
|
-- > safeMinimumOn id [] == Nothing
|
|
-- > safeMinimumOn length ["test","extra","a"] == Just "a"
|
|
safeMinimumOn :: (Foldable t,Ord b) => (a -> b) -> t a -> Maybe a
|
|
{-# INLINE safeMinimumOn #-}
|
|
safeMinimumOn f = foldl' g Nothing
|
|
where
|
|
g (Just x) y
|
|
| f x < f y = Just x
|
|
| otherwise = Just y
|
|
g Nothing y = Just y
|
|
|
|
minOn :: Ord b => (a -> b) -> a -> a -> a
|
|
minOn f x y
|
|
| f x < f y = x
|
|
| otherwise = y
|
|
safeMinimumOnMaybeF :: (Ord b) => (a -> Maybe b) -> [a] -> Maybe a
|
|
safeMinimumOnMaybeF f = L.fold $ L.Fold step initial extract
|
|
where
|
|
initial = Nothing
|
|
step Nothing x = (x ,) <$> f x
|
|
step (Just (a,x)) b = case f b of
|
|
Just y | y < x -> Just (b,y)
|
|
_ -> Just (a,x)
|
|
extract = fmap fst
|
|
safeMinMaybeL :: (Ord b) => (a -> Maybe b) -> L.Fold a (Maybe b)
|
|
safeMinMaybeL f = L.Fold step initial id
|
|
where
|
|
initial = Nothing
|
|
step Nothing x = f x
|
|
step (Just x) b = case f b of
|
|
Just y | y < x -> Just y
|
|
_ -> Just x
|
|
|
|
safeMinimumOnMaybeL :: (Ord b) => (a -> Maybe b) -> L.Fold a (Maybe a)
|
|
safeMinimumOnMaybeL f = L.Fold step initial extract
|
|
where
|
|
initial = Nothing
|
|
step Nothing x = (x ,) <$> f x
|
|
step (Just (a,x)) b = case f b of
|
|
Just y | y < x -> Just (b,y)
|
|
_ -> Just (a,x)
|
|
extract = fmap fst
|
|
|
|
safeMinimumOnMaybe :: (Ord b) => (a -> Maybe b) -> [a] -> Maybe a
|
|
safeMinimumOnMaybe f ys = fst <$> go Nothing ys
|
|
where
|
|
go Nothing (x:xs) = go ((x ,) <$> f x) xs
|
|
go (Just (y,cmin)) (x:xs) = case f x of
|
|
Just v | v < cmin -> go (Just (x,v)) xs
|
|
_ -> go (Just (y,cmin)) xs
|
|
go m _ = m
|
|
|
|
filter3 :: Foldable t
|
|
=> (a -> Bool)
|
|
-> (a -> Bool)
|
|
-> (a -> Bool)
|
|
-> t a
|
|
-> ([a],[a],[a])
|
|
filter3 t1 t2 t3 = L.fold $ (,,)
|
|
<$> L.prefilter t1 L.list
|
|
<*> L.prefilter t2 L.list
|
|
<*> L.prefilter t3 L.list
|
|
|
|
--{- | Partial. -}
|
|
--minimumOn :: Ord b => (a -> b) -> [a] -> a
|
|
--minimumOn f [] = error "tried to take minimumOn of empty list"
|
|
--minimumOn f (x:xs) = go x xs
|
|
-- where
|
|
-- go x (y:xs) | f x < f y = go x xs
|
|
-- | otherwise = go y xs
|
|
-- go x [] = x
|
|
|
|
{- | Implementation copied from
|
|
- https://hackage.haskell.org/package/utility-ht-0.0.16/docs/src/Data.List.HT.Private.html#takeUntil
|
|
-}
|
|
takeUntil :: Foldable t => (a -> Bool) -> t a -> [a]
|
|
takeUntil p = foldr (\x xs -> x : if p x then [] else xs) []
|
|
|
|
-- from haskell-cafe
|
|
-- short circuit a fold when a given property is satisfied
|
|
-- the fold builds a function that is then called on a0
|
|
ssfold :: Foldable t => (a -> Bool) -> (a -> b -> a) -> a -> t b -> a
|
|
{-# INLINABLE ssfold #-}
|
|
ssfold p f a0 xs = foldr (\x g a -> if p a then a else g (f a x)) id xs a0
|
|
|