-- Copyright 2021 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Program to query the module graph.
module Shake.ImportQueryMain where
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Tree as Tree

import qualified System.Environment as Environment
import qualified System.IO as IO
import qualified Text.Read as Read

import qualified Util.Lists as Lists
import qualified Util.Num as Num
import qualified Util.Trees as Trees

import qualified Shake.ImportQuery as ImportQuery
import           Shake.ImportQuery (Module)

import           Global


main :: IO ()
main :: IO ()
main = do
    IO [[Char]]
Environment.getArgs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [Char]
cmd : [[Char]]
args -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
cmd Map [Char] ([Char], [[Char]] -> Either [[Char]] (IO ()))
commands of
            Maybe ([Char], [[Char]] -> Either [[Char]] (IO ()))
Nothing -> [Char] -> IO ()
die [Char]
"unknown command"
            Just ([Char]
_, [[Char]] -> Either [[Char]] (IO ())
parse) -> case [[Char]] -> Either [[Char]] (IO ())
parse [[Char]]
args of
                Left [[Char]]
expected -> [Char] -> IO ()
die forall a b. (a -> b) -> a -> b
$ [Char]
"expected args: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [[Char]]
expected
                    forall a. Semigroup a => a -> a -> a
<> [Char]
" but got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [[Char]]
args
                Right IO ()
cmd -> IO ()
cmd
        [[Char]]
_ -> [Char] -> IO ()
die [Char]
"expected 1 command"
    where
    die :: [Char] -> IO ()
die [Char]
msg = do
        [Char] -> IO ()
putStrLn [Char]
msg
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
putStrLn
            [ [Char]
cmd forall a. Semigroup a => a -> a -> a
<> [Char]
" - " forall a. Semigroup a => a -> a -> a
<> [Char]
doc
            | ([Char]
cmd, ([Char]
doc, [[Char]] -> Either [[Char]] (IO ())
_)) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map [Char] ([Char], [[Char]] -> Either [[Char]] (IO ()))
commands
            ]

type Doc = String

commands :: Map String (Doc, ([String] -> Either [String] (IO ())))
commands :: Map [Char] ([Char], [[Char]] -> Either [[Char]] (IO ()))
commands = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
name, [Char]
doc, [[Char]] -> Either [[Char]] (IO ())
cmd) -> ([Char]
name, ([Char]
doc, [[Char]] -> Either [[Char]] (IO ())
cmd)))
    [ ( [Char]
"cache"
      , [Char]
"recreate cache in " forall a. Semigroup a => a -> a -> a
<> [Char]
ImportQuery.cacheFile
      , forall {b} {a} {a}. b -> [a] -> Either [a] b
parse0 IO ()
ImportQuery.cacheGraph
      )
    , ( [Char]
"weak"
      , [Char]
"Report weak links, which are imports that would reduce the closure\
        \ by a lot if broken."
      , forall {b} {a} {a}. b -> [a] -> Either [a] b
parse0 IO ()
cWeak
      )
    , ( [Char]
"rm"
      , [Char]
"Show what would happen to the import closure if an import was removed."
      , forall {a} {b}.
a -> a -> (Text -> Text -> b) -> [[Char]] -> Either [a] b
parse2 [Char]
"parent" [Char]
"removed" Text -> Text -> IO ()
cRm
      )
    , ( [Char]
"add"
      , [Char]
"Show what would happen to the import closure if an import was added."
      , forall {a} {b}.
a -> a -> (Text -> Text -> b) -> [[Char]] -> Either [a] b
parse2 [Char]
"parent" [Char]
"new" Text -> Text -> IO ()
cAdd
      )
    , ( [Char]
"path"
      , [Char]
"Show the way the parent imports the child."
      , forall {a} {b}.
a -> a -> (Text -> Text -> b) -> [[Char]] -> Either [a] b
parse2 [Char]
"parent" [Char]
"child" Text -> Text -> IO ()
cPath
      )
    ]
    where
    parse0 :: b -> [a] -> Either [a] b
parse0 b
cmd = \case
        [] -> forall a b. b -> Either a b
Right b
cmd
        [a]
_ -> forall a b. a -> Either a b
Left []
    parse2 :: a -> a -> (Text -> Text -> b) -> [[Char]] -> Either [a] b
parse2 a
a1 a
a2 Text -> Text -> b
cmd = \case
        [[Char]
arg1, [Char]
arg2] -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text -> b
cmd ([Char] -> Text
fnameToModule [Char]
arg1) ([Char] -> Text
fnameToModule [Char]
arg2)
        [[Char]]
_ -> forall a b. a -> Either a b
Left [a
a1, a
a2]

cWeak :: IO ()
cWeak :: IO ()
cWeak = do
    IO ()
ImportQuery.cacheGraph
    [(Int, ((Text, Text), [(Text, Set Text)]))]
scores <- CachedGraph -> [(Int, ((Text, Text), [(Text, Set Text)]))]
ImportQuery.findWeakLinks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CachedGraph
ImportQuery.loadCachedGraph
    Int
total <- forall (m :: * -> *) state a.
Monad m =>
(state -> a -> m state) -> state -> [a] -> m state
mapStateM forall {b} {b}.
(Ord b, Num b, Show b) =>
b -> (b, ((Text, Text), b)) -> IO b
fmt Int
0 [(Int, ((Text, Text), [(Text, Set Text)]))]
scores
    -- Make the total line parseable by parseWeaks
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
total forall a. Semigroup a => a -> a -> a
<> [Char]
" TOTAL TOTAL"
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"total: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
total
    where
    fmt :: b -> (b, ((Text, Text), b)) -> IO b
fmt b
total (b
score, ((Text
parent, Text
rm), b
_rms)) = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (b
score forall a. Ord a => a -> a -> Bool
> b
3) forall a b. (a -> b) -> a -> b
$ do
            Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords [forall a. Show a => a -> Text
showt b
score, Text
parent, Text
rm]
            Handle -> IO ()
IO.hFlush Handle
IO.stdout
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ b
total forall a. Num a => a -> a -> a
+ b
score

mapStateM :: Monad m => (state -> a -> m state) -> state -> [a] -> m state
mapStateM :: forall (m :: * -> *) state a.
Monad m =>
(state -> a -> m state) -> state -> [a] -> m state
mapStateM state -> a -> m state
action state
state = \case
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure state
state
    a
x : [a]
xs -> do
        !state
state <- state -> a -> m state
action state
state a
x
        forall (m :: * -> *) state a.
Monad m =>
(state -> a -> m state) -> state -> [a] -> m state
mapStateM state -> a -> m state
action state
state [a]
xs

cRm :: Module -> Module -> IO ()
cRm :: Text -> Text -> IO ()
cRm Text
parent Text
removed = do
    CachedGraph
graph <- IO CachedGraph
ImportQuery.loadCachedGraph
    let rms :: [(Text, Set Text)]
rms = CachedGraph -> Text -> Text -> [(Text, Set Text)]
ImportQuery.rmDep CachedGraph
graph Text
parent Text
removed
    if  | Text
parent forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` CachedGraph -> Graph
ImportQuery._graph CachedGraph
graph ->
            Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"no parent module: " forall a. Semigroup a => a -> a -> a
<> Text
parent
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Set Text)]
rms -> Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
parent forall a. Semigroup a => a -> a -> a
<> Text
" doesn't import " forall a. Semigroup a => a -> a -> a
<> Text
removed
        | Bool
otherwise -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
Text.IO.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Set Text) -> Text
prettyRmDep) forall a b. (a -> b) -> a -> b
$
                forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn (forall a. Set a -> Int
Set.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Text, Set Text)]
rms
            [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"total lost: "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Set a -> Int
Set.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Text, Set Text)]
rms))

prettyRmDep :: (Module, Set Module) -> Text
prettyRmDep :: (Text, Set Text) -> Text
prettyRmDep (Text
mod, Set Text
lost) = Text
mod forall a. Semigroup a => a -> a -> a
<> Text
" - "
    forall a. Semigroup a => a -> a -> a
<> (if forall a. Set a -> Int
Set.size Set Text
lost forall a. Ord a => a -> a -> Bool
> Int
2 then forall a. Show a => a -> Text
showt (forall a. Set a -> Int
Set.size Set Text
lost) forall a. Semigroup a => a -> a -> a
<> Text
":" else Text
"")
    forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"," (forall a. Set a -> [a]
Set.toList Set Text
lost)

cAdd :: Module -> Module -> IO ()
cAdd :: Text -> Text -> IO ()
cAdd Text
parent Text
new = do
    Graph
graph <- IO Graph
ImportQuery.loadGraph
    case Graph -> Text -> Text -> Either [[Text]] (Tree Text)
ImportQuery.addDep Graph
graph Text
parent Text
new of
        Left [[Text]]
paths -> do
            [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"already imported via paths:"
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
Text.IO.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"->") [[Text]]
paths
        Right Tree Text
tree -> do
            [Char] -> IO ()
putStrLn [Char]
"New modules added, * marks already imported ones:"
            [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ Tree Text -> [Char]
draw Tree Text
tree
            [Char] -> IO ()
putStrLn [Char]
"Adds only:"
            [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"nothing?" Tree Text -> [Char]
draw forall a b. (a -> b) -> a -> b
$
                forall a. (a -> Bool) -> Tree a -> Maybe (Tree a)
Trees.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"*" `Text.isSuffixOf`)) Tree Text
tree

cPath :: Module -> Module -> IO ()
cPath :: Text -> Text -> IO ()
cPath Text
parent Text
child = do
    Graph
graph <- IO Graph
ImportQuery.loadGraph
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ case Graph -> Text -> Text -> [[Text]]
ImportQuery.paths Graph
graph Text
parent Text
child of
        [] -> [Text
"no path from " forall a. Semigroup a => a -> a -> a
<> Text
parent forall a. Semigroup a => a -> a -> a
<> Text
" to " forall a. Semigroup a => a -> a -> a
<> Text
child]
        [[Text]]
paths -> forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Text] -> Text
Text.intercalate Text
" -> ") [[Text]]
paths

draw :: Tree.Tree Text -> String
draw :: Tree Text -> [Char]
draw = Tree [Char] -> [Char]
Tree.drawTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
untxt

fnameToModule :: String -> ImportQuery.Module
fnameToModule :: [Char] -> Text
fnameToModule =
    [Char] -> Text
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> [a] -> [a] -> [a]
Lists.replace1 Char
'/' [Char]
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char] -> [Char]
dropSuffixes [[Char]
".hs", [Char]
".hsc", [Char]
".chs"]

dropSuffixes :: [String] -> FilePath -> String
dropSuffixes :: [[Char]] -> [Char] -> [Char]
dropSuffixes [[Char]]
suffixes [Char]
str =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
str (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Eq a => [a] -> [a] -> ([a], Bool)
Lists.dropSuffix [Char]
str) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\[Char]
suf -> [Char]
suf forall a. Eq a => [a] -> [a] -> Bool
`List.isSuffixOf` [Char]
str) [[Char]]
suffixes

-- Call from ghci.
updateWeaks :: IO ()
updateWeaks :: IO ()
updateWeaks = do
    Map (Text, Text) Parsed
old <- Text -> Map (Text, Text) Parsed
parseWeaks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
Text.IO.readFile [Char]
"weak-links"
    Map (Text, Text) Parsed
new <- Text -> Map (Text, Text) Parsed
parseWeaks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
Text.IO.readFile [Char]
"weak-links2"
    [Char] -> Text -> IO ()
Text.IO.writeFile [Char]
"weak-links-merged" forall a b. (a -> b) -> a -> b
$ Map (Text, Text) Parsed -> Text
unparseWeaks (forall k. Ord k => Map k Parsed -> Map k Parsed -> Map k Parsed
mergeWeaks Map (Text, Text) Parsed
old Map (Text, Text) Parsed
new)

mergeWeaks :: Ord k => Map k Parsed -> Map k Parsed -> Map k Parsed
mergeWeaks :: forall k. Ord k => Map k Parsed -> Map k Parsed -> Map k Parsed
mergeWeaks Map k Parsed
old Map k Parsed
new = forall k a1 b a2.
Ord k =>
(Paired a1 b -> a2) -> Map k a1 -> Map k b -> Map k a2
merge Paired Parsed Parsed -> Parsed
m Map k Parsed
old Map k Parsed
new
    where
    m :: Paired Parsed Parsed -> Parsed
m = \case
        Lists.Both (Parsed Char
sigil Int
count1 [Text]
comments) (Parsed Char
_ Int
count [Text]
_) -> Parsed
            { _sigil :: Char
_sigil = Char
sigil
            , _count :: Int
_count = Int
count
            , _comments :: [Text]
_comments = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Text
"") forall a b. (a -> b) -> a -> b
$ if Int
count1 forall a. Eq a => a -> a -> Bool
/= Int
count
                then Text
"[" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
count1 forall a. Semigroup a => a -> a -> a
<> Text
"]" forall a. a -> [a] -> [a]
: [Text]
comments
                else [Text]
comments
            }
        Lists.Second Parsed
a -> Parsed
a
        -- '_' means this dep disappeared.
        Lists.First (Parsed Char
_ Int
count [Text]
comments) -> Char -> Int -> [Text] -> Parsed
Parsed Char
'_' Int
count [Text]
comments

unparseWeaks :: Map (Text, Text) Parsed -> Text
unparseWeaks :: Map (Text, Text) Parsed -> Text
unparseWeaks =
    forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text, Text) -> Parsed -> Text
unparseWeak) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [a] -> [a]
List.sortOn (Parsed -> Int
_count forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList

data Parsed = Parsed {
    Parsed -> Char
_sigil :: Char
    , Parsed -> Int
_count :: Int
    , Parsed -> [Text]
_comments :: [Text]
    } deriving (Int -> Parsed -> [Char] -> [Char]
[Parsed] -> [Char] -> [Char]
Parsed -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Parsed] -> [Char] -> [Char]
$cshowList :: [Parsed] -> [Char] -> [Char]
show :: Parsed -> [Char]
$cshow :: Parsed -> [Char]
showsPrec :: Int -> Parsed -> [Char] -> [Char]
$cshowsPrec :: Int -> Parsed -> [Char] -> [Char]
Show)

unparseWeak :: (Text, Text) -> Parsed -> Text
unparseWeak :: (Text, Text) -> Parsed -> Text
unparseWeak (Text
parent, Text
child) (Parsed Char
sigil Int
count [Text]
comments_) = [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$
    [Text] -> Text
Text.unwords ([Char -> Text
Text.singleton Char
sigil, forall a. Show a => a -> Text
showt Int
count, Text
parent, Text
child] forall a. [a] -> [a] -> [a]
++ [Text]
status)
    forall a. a -> [a] -> [a]
: [Text]
comments
    where
    -- Following comments lines start with ' '.
    ([Text]
status, [Text]
comments) = case [Text]
comments_ of
        Text
c : [Text]
cs | (Char -> Bool) -> Text -> Bool
Text.all (forall a. Eq a => a -> a -> Bool
/=Char
' ') Text
c -> ([Text
c], [Text]
cs)
        [Text]
_ -> ([], [Text]
comments_)

parseWeaks :: Text -> Map (Text, Text) Parsed
parseWeaks :: Text -> Map (Text, Text) Parsed
parseWeaks =
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. ((a, (Char, Int, Text)), [Text]) -> (a, Parsed)
convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(Maybe a, b)] -> [(a, [b])]
collectJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn Text -> Maybe ((Text, Text), (Char, Int, Text))
parseSigil
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
    where
    convert :: ((a, (Char, Int, Text)), [Text]) -> (a, Parsed)
convert ((a
k, (Char
sigil, Int
count, Text
comment1)), [Text]
comments) =
        (a
k, Char -> Int -> [Text] -> Parsed
Parsed Char
sigil Int
count (Text
comment1 forall a. a -> [a] -> [a]
: [Text]
comments))

parseSigil :: Text -> Maybe ((Text, Text), (Char, Int, Text))
parseSigil :: Text -> Maybe ((Text, Text), (Char, Int, Text))
parseSigil Text
line = case Text -> Maybe (Char, Text)
Text.uncons Text
line of
    Just (Char
c, Text
line)
        | Char -> Bool
isSigil Char
c, Text
ds : Text
parent : Text
child : [Text]
c1 <- Text -> [Text]
Text.words Text
line,
            Just Int
d <- forall a. Read a => [Char] -> Maybe a
Read.readMaybe (Text -> [Char]
untxt Text
ds) ->
        forall a. a -> Maybe a
Just ((Text
parent, Text
child), (Char
c, Int
d, [Text] -> Text
Text.unwords [Text]
c1))
    Maybe (Char, Text)
_ -> forall a. Maybe a
Nothing
    where
    isSigil :: Char -> Bool
isSigil Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char -> Bool
Char.isPunctuation Char
c


-- * util

collectJust :: [(Maybe a, b)] -> [(a, [b])]
collectJust :: forall a b. [(Maybe a, b)] -> [(a, [b])]
collectJust ((Just a
a, b
_b) : [(Maybe a, b)]
xs) = (a
a, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Maybe a, b)]
pre) forall a. a -> [a] -> [a]
: forall a b. [(Maybe a, b)] -> [(a, [b])]
collectJust [(Maybe a, b)]
post
    where ([(Maybe a, b)]
pre, [(Maybe a, b)]
post) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Maybe a -> Bool
Maybe.isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Maybe a, b)]
xs
collectJust ((Maybe a
Nothing, b
_b) : [(Maybe a, b)]
xs) = forall a b. [(Maybe a, b)] -> [(a, [b])]
collectJust [(Maybe a, b)]
xs
collectJust [] = []

-- | Data.Map has a merge which can probably do this, but it's so complicated
-- I gave up on it.
merge :: Ord k => (Lists.Paired a1 b -> a2) -> Map k a1 -> Map k b -> Map k a2
merge :: forall k a1 b a2.
Ord k =>
(Paired a1 b -> a2) -> Map k a1 -> Map k b -> Map k a2
merge Paired a1 b -> a2
merger Map k a1
m1 Map k b
m2 = forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Paired a1 b -> a2
merger) forall a b. (a -> b) -> a -> b
$
    forall k a b. Ord k => [(k, a)] -> [(k, b)] -> [(k, Paired a b)]
Lists.pairSorted (forall k a. Map k a -> [(k, a)]
Map.toAscList Map k a1
m1) (forall k a. Map k a -> [(k, a)]
Map.toAscList Map k b
m2)