125 lines
4.3 KiB
Haskell
125 lines
4.3 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
|
|
-
|
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
-
|
|
- The author(s) have dedicated all copyright and related and neighboring
|
|
- rights to this software to the public domain worldwide. This software is
|
|
- distributed without any warranty.
|
|
-
|
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
- with this software. If not, see
|
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
-}
|
|
|
|
module Data.List.Local
|
|
( -- groupByFst
|
|
groupJusts
|
|
, groupEithers
|
|
, groupPairs
|
|
, groupMap
|
|
, groupMapBy
|
|
, groupMapBy1
|
|
, lookupSorted
|
|
, sortAlign
|
|
)
|
|
where
|
|
|
|
import Data.Bifunctor
|
|
import Data.Function (on)
|
|
import Data.List.NonEmpty (NonEmpty (..), (<|), toList)
|
|
import Data.These
|
|
|
|
import qualified Data.List.Ordered as LO
|
|
|
|
-- | Takes a list of pairs and groups them by consecutive ranges with equal
|
|
-- first element. Returns a list of pairs, where each pair corresponds to one
|
|
-- such range.
|
|
--groupByFst :: Eq a => [(a, b)] -> [(a, [b])]
|
|
--groupByFst [] = []
|
|
--groupByFst ((x, y):ps) =
|
|
-- let (same, rest) = span ((== x) . fst) ps
|
|
-- in (x, y : map snd same) : groupByFst rest
|
|
|
|
-- | Group together sublists of Just items, and drop the Nothing items.
|
|
--
|
|
-- >>> groupJusts [Nothing, Nothing, Just 1, Just 4, Nothing, Just 2]
|
|
-- [[1, 4], [2]]
|
|
groupJusts :: Foldable f => f (Maybe a) -> [NonEmpty a]
|
|
groupJusts maybes = prepend $ foldr go (Nothing, []) maybes
|
|
where
|
|
prepend (Nothing, l) = l
|
|
prepend (Just x , l) = x : l
|
|
go Nothing (Nothing, ls) = (Nothing , ls)
|
|
go Nothing (Just l , ls) = (Nothing , l : ls)
|
|
go (Just x) (Nothing, ls) = (Just $ x :| [], ls)
|
|
go (Just x) (Just l , ls) = (Just $ x <| l , ls)
|
|
|
|
groupEithers :: Foldable f => f (Either a b) -> ([b], [(NonEmpty a, NonEmpty b)], [a])
|
|
groupEithers = foldr go ([], [], [])
|
|
where
|
|
go (Left x) ([] , [] , as) = ([], [] , x : as)
|
|
go (Left x) ([] , (xs, ys):ps, as) = ([], (x <| xs, ys) : ps , as)
|
|
go (Left x) (b:bs, ps , as) = ([], (x :| [], b :| bs) : ps, as)
|
|
go (Right y) (bs, ps, as) = (y : bs, ps, as)
|
|
|
|
groupPairs
|
|
:: Foldable f => f ([a], [b]) -> ([b], [(NonEmpty a, NonEmpty b)], [a])
|
|
groupPairs = groupEithers . foldr go []
|
|
where
|
|
go (xs, ys) es = map Left xs ++ map Right ys ++ es
|
|
|
|
-- | @groupMap f g l@ groups elements like 'group', except it compares them by
|
|
-- applying @f@ to elements and comparing these values using the 'Eq' instance.
|
|
-- It then maps the elements in each such equality group using @g@.
|
|
--
|
|
-- >>> groupMap fst snd [(1, 5), (1, 6), (2, 7), (2, 8), (2, 9)]
|
|
-- [(1, [5, 6]), (2, [7, 8, 9])]
|
|
groupMap :: Eq b => (a -> b) -> (a -> c) -> [a] -> [(b, NonEmpty c)]
|
|
groupMap f = groupMapBy ((==) `on` f) f
|
|
|
|
-- | Like 'groupMap', except it uses a comparison predicate instead of an 'Eq'
|
|
-- instance.
|
|
groupMapBy
|
|
:: (a -> a -> Bool) -> (a -> b) -> (a -> c) -> [a] -> [(b, NonEmpty c)]
|
|
groupMapBy _ _ _ [] = []
|
|
groupMapBy eq f g (x:xs) = toList $ groupMapBy1 eq f g $ x :| xs
|
|
|
|
-- | Like 'groupMapBy1', but takes and returns a 'NonEmpty'.
|
|
groupMapBy1
|
|
:: (a -> a -> Bool)
|
|
-> (a -> b)
|
|
-> (a -> c)
|
|
-> NonEmpty a
|
|
-> NonEmpty (b, NonEmpty c)
|
|
groupMapBy1 eq f g = go
|
|
where
|
|
go (x :| xs) =
|
|
let (ys, zs) = span (eq x) xs
|
|
rest = case zs of
|
|
[] -> []
|
|
z:l -> toList $ go $ z :| l
|
|
in (f x, g x :| map g ys) :| rest
|
|
|
|
lookupSorted :: Ord a => a -> [(a, b)] -> Maybe b
|
|
lookupSorted _ [] = Nothing
|
|
lookupSorted x ((y, z) : l) =
|
|
case compare x y of
|
|
LT -> lookupSorted x l
|
|
EQ -> Just z
|
|
GT -> Nothing
|
|
|
|
sortAlign :: Ord a => [(a, b)] -> [(a, b)] -> [(a, These b b)]
|
|
sortAlign xs ys = orderedAlign (prepare xs) (prepare ys)
|
|
where
|
|
prepare = LO.nubSortOn' fst
|
|
|
|
orderedAlign :: Ord a => [(a, b)] -> [(a, b)] -> [(a, These b b)]
|
|
orderedAlign [] ys = map (second That) ys
|
|
orderedAlign xs [] = map (second This) xs
|
|
orderedAlign xs@((u, w) : us) ys@((v, z) : vs) =
|
|
case compare u v of
|
|
LT -> (u, This w) : orderedAlign us ys
|
|
EQ -> (u, These w z) : orderedAlign us vs
|
|
GT -> (v, That z) : orderedAlign xs vs
|