-- 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

-- | Utilities to generate and query the import graph.
module Shake.ImportQuery where
import qualified Data.Aeson as Aeson
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.Tree as Tree

import qualified System.FilePath as FilePath
import qualified System.Process as Process

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

import qualified Shake.HsDeps as HsDeps

import           Global


{-
    queries:
    If I add or remove an import, how does that change the transitive imports?
        . Get transitive closure before and after, show difference.
    What is the transitive closure of the imports of this module?
    What are the paths from A to B?

    I want to not just show as a list, but as a tree.
      . For each import, print the number of transitive things it imports.
-}

type Graph = Map Module [Module] -- TODO Set
type Module = Text

data CachedGraph = CachedGraph {
    CachedGraph -> Graph
_graph :: Graph
    , CachedGraph -> Map Module (Set Module)
_closures :: Map Module (Set Module)
    } deriving (Int -> CachedGraph -> ShowS
[CachedGraph] -> ShowS
CachedGraph -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CachedGraph] -> ShowS
$cshowList :: [CachedGraph] -> ShowS
show :: CachedGraph -> FilePath
$cshow :: CachedGraph -> FilePath
showsPrec :: Int -> CachedGraph -> ShowS
$cshowsPrec :: Int -> CachedGraph -> ShowS
Show)

cachedGraph :: Graph -> CachedGraph
cachedGraph :: Graph -> CachedGraph
cachedGraph Graph
g = CachedGraph
    { _graph :: Graph
_graph = Graph
g
    , _closures :: Map Module (Set Module)
_closures = forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\Module
m [Module]
_ -> Graph -> Module -> Set Module
closure Graph
g Module
m) Graph
g
    }

loadCachedGraph :: IO CachedGraph
loadCachedGraph :: IO CachedGraph
loadCachedGraph = Graph -> CachedGraph
cachedGraph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Graph
loadGraph

-- | If I add some import, what do I now depend on that I didn't before?
--
-- It's the new closure minus the previous one.
-- If I already imported that module, it's Left and the paths that show I
-- already depend.
-- If I didn't, I added it, plus whatever non-zero adds it implies.
-- TODO If it's circular, report that!
addDep :: Graph -> Module -> Module -> Either [[Module]] (Tree.Tree Module)
addDep :: Graph -> Module -> Module -> Either [[Module]] (Tree Module)
addDep Graph
graph Module
parent Module
new
    | forall a. Ord a => a -> Set a -> Bool
Set.member Module
new Set Module
oldClosure = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Graph -> Module -> Module -> [[Module]]
paths Graph
graph Module
parent Module
new
    | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Set Module -> Tree Module -> Tree Module
trimTree Set Module
oldClosure forall a b. (a -> b) -> a -> b
$ Graph -> Module -> Tree Module
closureTree Graph
graph Module
new
    where oldClosure :: Set Module
oldClosure = Graph -> Module -> Set Module
closure Graph
graph Module
parent

-- | If I remove Perform.Signal from Derive.ScoreT, who now has fewer deps?
rmDep :: CachedGraph -> Module -> Module -> [(Module, Set Module)]
rmDep :: CachedGraph -> Module -> Module -> [(Module, Set Module)]
rmDep CachedGraph
graph Module
parent Module
removed =
    forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty) 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 a k. (a -> k) -> [a] -> [(a, k)]
Lists.keyOnSnd Module -> Set Module
gone forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys (CachedGraph -> Graph
_graph CachedGraph
graph)
    -- TODO this builds the complete closure of every module twice, only
    -- to filter out the ones that wind up empty.  Is there a way to
    -- find out there is no difference to short-circuit?
    where
    -- TODO emit this as a tree!
    gone :: Module -> Set Module
gone Module
mod = forall k a. (Ord k, Monoid a) => k -> Map k a -> a
get Module
mod (CachedGraph -> Map Module (Set Module)
_closures CachedGraph
graph) forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Graph -> Module -> Set Module
closure Graph
without Module
mod
    without :: Graph
without = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Module
removed)) Module
parent (CachedGraph -> Graph
_graph CachedGraph
graph)

{-
    It would be interesting to find all the single drops with the highest lost
    score.  It won't reveal when I could drop two things... seems like there
    should be some kind of graph algorithm to find the weakest links holding
    the heaviest subgraph.

    Brute force way would be to do rmDep on each import of each module, and
    sort by scale.  That's probably too expensive if I want to try to remove 2.

    TODO brute force way is slow even for just one link.
-}

-- | This implements the brute-force way of seeing which single imports can be
-- removed for the greatest reduction in dependencies.
findWeakLinks :: CachedGraph -> [(Int, ((Text, Text), [(Module, Set Module)]))]
findWeakLinks :: CachedGraph -> [(Int, ((Module, Module), [(Module, Set Module)]))]
findWeakLinks CachedGraph
graph = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Module -> [(Int, ((Module, Module), [(Module, Set Module)]))]
get forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Module -> Bool
wanted forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys (CachedGraph -> Graph
_graph CachedGraph
graph)
    where
    get :: Module -> [(Int, ((Module, Module), [(Module, Set Module)]))]
get Module
parent = forall a b. (a -> b) -> [a] -> [b]
map (Module
-> Module -> (Int, ((Module, Module), [(Module, Set Module)]))
get1 Module
parent) (Module -> Graph -> [Module]
importsOf Module
parent (CachedGraph -> Graph
_graph CachedGraph
graph))
    get1 :: Module
-> Module -> (Int, ((Module, Module), [(Module, Set Module)]))
get1 Module
parent Module
removed = (forall {a} {a}. [(a, Set a)] -> Int
scoreOf [(Module, Set Module)]
rms, ((Module
parent, Module
removed), [(Module, Set Module)]
rms))
        where rms :: [(Module, Set Module)]
rms = CachedGraph -> Module -> Module -> [(Module, Set Module)]
rmDep CachedGraph
graph Module
parent Module
removed
    scoreOf :: [(a, Set a)] -> Int
scoreOf = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
    wanted :: Module -> Bool
wanted Module
mod = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Module -> Module -> Bool
`Text.isSuffixOf` Module
mod) [Module
"_test", Module
"_profile"]

-- TODO common up the prefixes into a tree?
-- TODO very slow, could I save time by memoizing branches I already searched?
-- Surely this is a standard DAG algorithm.
paths :: Graph -> Module -> Module -> [[Module]]
paths :: Graph -> Module -> Module -> [[Module]]
paths Graph
graph Module
from Module
to
    | Module
from forall a. Eq a => a -> a -> Bool
== Module
to = [[Module
to]]
    | Bool
otherwise = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
from Graph
graph of
        Maybe [Module]
Nothing -> []
        Just [Module]
mods -> [Module
fromforall a. a -> [a] -> [a]
:[Module]
path | Module
m <- [Module]
mods, [Module]
path <- Graph -> Module -> Module -> [[Module]]
paths Graph
graph Module
m Module
to]

closureTree :: Graph -> Module -> Tree.Tree Module
closureTree :: Graph -> Module -> Tree Module
closureTree Graph
graph Module
mod =
    forall a. a -> [Tree a] -> Tree a
Tree.Node Module
mod (forall a b. (a -> b) -> [a] -> [b]
map (Graph -> Module -> Tree Module
closureTree Graph
graph) (Module -> Graph -> [Module]
importsOf Module
mod Graph
graph))

trimTree :: Set Module -> Tree.Tree Module -> Tree.Tree Module
trimTree :: Set Module -> Tree Module -> Tree Module
trimTree Set Module
seen = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
(Ord a, Semigroup a, IsString a) =>
Set a -> Tree a -> (Set a, Tree a)
go Set Module
seen
    where
    go :: Set a -> Tree a -> (Set a, Tree a)
go Set a
seen (Tree.Node a
mod [Tree a]
subs)
        | forall a. Ord a => a -> Set a -> Bool
Set.member a
mod Set a
seen = (Set a
seen, forall a. a -> [Tree a] -> Tree a
Tree.Node (a
mod forall a. Semigroup a => a -> a -> a
<> a
"*") [])
        | Bool
otherwise = forall a. a -> [Tree a] -> Tree a
Tree.Node a
mod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Set a -> Tree a -> (Set a, Tree a)
go (forall a. Ord a => a -> Set a -> Set a
Set.insert a
mod Set a
seen) [Tree a]
subs

-- | Closure as a list so you can abort as soon as you find something.
closureList :: Graph -> Module -> [Module]
closureList :: Graph -> Module -> [Module]
closureList Graph
graph = forall a. Tree a -> [a]
Tree.flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> Module -> Tree Module
closureTree Graph
graph

closure :: Graph -> Module -> Set Module
closure :: Graph -> Module -> Set Module
closure Graph
graph = Set Module -> Module -> Set Module
go forall a. Set a
Set.empty
    where
    go :: Set Module -> Module -> Set Module
go Set Module
seen Module
mod
        | Module
mod forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
seen = Set Module
seen
        | Bool
otherwise = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Set Module -> Module -> Set Module
go (forall a. Ord a => a -> Set a -> Set a
Set.insert Module
mod Set Module
seen) (Module -> Graph -> [Module]
importsOf Module
mod Graph
graph)

importsOf :: Module -> Graph -> [Module]
importsOf :: Module -> Graph -> [Module]
importsOf = forall k a. (Ord k, Monoid a) => k -> Map k a -> a
get

get :: (Ord k, Monoid a) => k -> Map k a -> a
get :: forall k a. (Ord k, Monoid a) => k -> Map k a -> a
get = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty

-- * generate

cacheGraph :: IO ()
cacheGraph :: IO ()
cacheGraph = forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile FilePath
cacheFile forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Graph
generateGraph

loadGraph :: IO Graph
loadGraph :: IO Graph
loadGraph = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => FilePath -> a
error FilePath
"no parse") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => FilePath -> IO (Maybe a)
Aeson.decodeFileStrict' FilePath
cacheFile

cacheFile :: FilePath
cacheFile :: FilePath
cacheFile = FilePath
"build/imports.json"

generateGraph :: IO Graph
generateGraph :: IO Graph
generateGraph =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap FilePath -> Module
fileToModule (forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Module
fileToModule))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
Maybe.catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) state x y.
Monad m =>
(state -> x -> m (state, y)) -> state -> [x] -> m (state, [y])
Lists.mapAccumLM Set FilePath
-> FilePath -> IO (Set FilePath, Maybe (FilePath, [FilePath]))
get forall a. Set a
Set.empty forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [FilePath]
getAllHs
    where
    get :: Set FilePath
-> FilePath -> IO (Set FilePath, Maybe (FilePath, [FilePath]))
get Set FilePath
seen FilePath
fname
        | forall a. Ord a => a -> Set a -> Bool
Set.member FilePath
fname Set FilePath
seen = forall (m :: * -> *) a. Monad m => a -> m a
return (Set FilePath
seen, forall a. Maybe a
Nothing)
        | Bool
otherwise = do
            [FilePath]
deps <- Generated -> Maybe [FilePath] -> FilePath -> IO [FilePath]
HsDeps.importsOfIO Generated
generatedSrc (FilePath -> Maybe [FilePath]
cppFlags FilePath
fname) FilePath
fname
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
fname Set FilePath
seen, forall a. a -> Maybe a
Just (FilePath
fname, [FilePath]
deps))

-- From Shakefile, but simplified.

getAllHs :: IO [FilePath]
getAllHs :: IO [FilePath]
getAllHs =
    forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isHs forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        FilePath -> [FilePath] -> FilePath -> IO FilePath
Process.readProcess FilePath
"git" [FilePath
"ls-tree", FilePath
"--name-only", FilePath
"-r", FilePath
"HEAD"] FilePath
""
    where isHs :: FilePath -> Bool
isHs FilePath
fn = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
`List.isSuffixOf` FilePath
fn) [FilePath
".hs", FilePath
".hsc", FilePath
".chs"]

generatedSrc :: HsDeps.Generated
generatedSrc :: Generated
generatedSrc = HsDeps.Generated
    { _generatedHs :: Set FilePath
_generatedHs = forall a. Ord a => [a] -> Set a
Set.fromList [FilePath
"Solkattu/All.hs"]
    , _generatedExtensions :: [FilePath]
_generatedExtensions = [FilePath
".hsc", FilePath
".chs"]
    }

cppFlags :: FilePath -> Maybe [String]
cppFlags :: FilePath -> Maybe [FilePath]
cppFlags FilePath
fn
    | FilePath
fn forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
cppInImports = forall a. a -> Maybe a
Just
        [ FilePath
"-Ibuild/debug"
        , FilePath
"-DTESTING"
        , FilePath
"-DBUILD_DIR=\"\""
        , FilePath
"-DGHC_VERSION=90001"
        ]
    | Bool
otherwise = forall a. Maybe a
Nothing

fileToModule :: FilePath -> Module
fileToModule :: FilePath -> Module
fileToModule = FilePath -> Module
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replace forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FilePath.dropExtensions
    where
    replace :: Char -> Char
replace Char
'/' = Char
'.'
    replace Char
c = Char
c

-- | Hardcoded list of modules that use CPP to determine their imports.
-- TODO duplicated with Shakefile.ccInImports.
cppInImports :: Set.Set FilePath
cppInImports :: Set FilePath
cppInImports = forall a. Ord a => [a] -> Set a
Set.fromList
    [ FilePath
"App/Main.hs"
    , FilePath
"Cmd/Repl.hs"
    , FilePath
"Midi/MidiDriver.hs"
    , FilePath
"App/LoadInstruments.hs"
    ]