Eventually-decentralized project hosting and management platform
Clone
HTTPS:
darcs clone https://vervis.peers.community/repos/WvWbo
SSH:
darcs clone USERNAME@vervis.peers.community:WvWbo
Tags
TODO
Local.hs
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 | {- 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
|