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

{-# LANGUAGE OverloadedStrings #-}
module Shake.HsDeps (
    Generated(..)
    , importsOf, transitiveImportsOf
    , importsOfIO
    , importsPackagagesOf_
    , loadPackageDb, savePackageDb
) where
import qualified Control.Concurrent as Concurrent
import qualified Control.Exception as Exception
import qualified Control.Monad.Trans as Trans

import qualified Data.ByteString.Char8 as B
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Serialize as Serialize
import qualified Data.Set as Set

import qualified Development.Shake as Shake
import qualified System.Directory as Directory
import qualified System.Exit as Exit
import qualified System.FilePath as FilePath
import qualified System.IO as IO
import qualified System.Process as Process

import qualified Util.Lists as Lists
import qualified Util.Maps as Maps
import qualified Shake.Util as Util

import           Control.Monad


type Package = String
type ModuleName = B.ByteString

-- | Normally 'importsOf' and 'transitiveImportsOf' filter out files that don't
-- exist, under the assumption that they belong to external packages.  This
-- set contains exceptions to that, so they will get a need call, so they can
-- be generated.
data Generated = Generated {
    Generated -> Set [Char]
_generatedHs :: Set.Set FilePath
    -- | Try files with these extensions, in addition to .hs.
    -- E.g. [".hsc", ".chs"].
    , Generated -> [[Char]]
_generatedExtensions :: [FilePath]
    } deriving (Generated -> Generated -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Generated -> Generated -> Bool
$c/= :: Generated -> Generated -> Bool
== :: Generated -> Generated -> Bool
$c== :: Generated -> Generated -> Bool
Eq, Int -> Generated -> ShowS
[Generated] -> ShowS
Generated -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Generated] -> ShowS
$cshowList :: [Generated] -> ShowS
show :: Generated -> [Char]
$cshow :: Generated -> [Char]
showsPrec :: Int -> Generated -> ShowS
$cshowsPrec :: Int -> Generated -> ShowS
Show)

-- | Find files of modules this module imports, in the form A/B.hs or A/B.hsc.
-- Paths that don't exist are assumed to be package imports and are omitted.
importsOf :: Generated -> Maybe [String] -> FilePath -> Shake.Action [FilePath]
importsOf :: Generated -> Maybe [[Char]] -> [Char] -> Action [[Char]]
importsOf Generated
generated Maybe [[Char]]
cppFlags [Char]
fn = do
    Partial => [[Char]] -> Action ()
Shake.need [[Char]
fn]
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO (Generated -> Maybe [[Char]] -> [Char] -> IO [[Char]]
importsOfIO Generated
generated Maybe [[Char]]
cppFlags [Char]
fn)

importsOfIO :: Generated
    -> Maybe [String] -- ^ If Just, first run CPP with these flags.
    -> FilePath -> IO [FilePath]
importsOfIO :: Generated -> Maybe [[Char]] -> [Char] -> IO [[Char]]
importsOfIO Generated
generated Maybe [[Char]]
cppFlags [Char]
fn = do
    -- TODO get CcDeps.includesOf so I can need them too.
    [ModuleName]
mods <- forall a. Ord a => [a] -> [a]
Lists.uniqueSort forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [ModuleName]
parseImports forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [[Char]] -> [Char] -> IO ModuleName
preprocess Maybe [[Char]]
cppFlags [Char]
fn
    forall a. [Maybe a] -> [a]
Maybe.catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Generated -> ModuleName -> IO (Maybe [Char])
fileOf Generated
generated) [ModuleName]
mods

-- * PackageDb

-- | Map a module name to the package it comes from.
type PackageDb = Map.Map ModuleName Package

-- | Get local imports and package dependencies.
--
-- I thought I wound use this but wound up not wanting it.  But I'll leave the
-- basic implementation here in case I change my mind.  This still needs to
-- be integrated with 'importsOf' and 'transitiveImportsOf'.
importsPackagagesOf_ :: PackageDb
    -> Generated -> Maybe [String] -- ^ If Just, first run CPP with these flags.
    -> FilePath -> IO ([FilePath], [Package])
importsPackagagesOf_ :: Map ModuleName [Char]
-> Generated -> Maybe [[Char]] -> [Char] -> IO ([[Char]], [[Char]])
importsPackagagesOf_ Map ModuleName [Char]
packageDb Generated
generated Maybe [[Char]]
cppFlags [Char]
fn = do
    [ModuleName]
mods <- ModuleName -> [ModuleName]
parseImports forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [[Char]] -> [Char] -> IO ModuleName
preprocess Maybe [[Char]]
cppFlags [Char]
fn
    [[Char]]
files <- forall a. [Maybe a] -> [a]
Maybe.catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Generated -> ModuleName -> IO (Maybe [Char])
fileOf Generated
generated) [ModuleName]
mods
    forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]]
files, forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map ModuleName [Char]
packageDb) [ModuleName]
mods)

-- | Load cached module to package db.
loadPackageDb :: FilePath -> Shake.Action PackageDb
loadPackageDb :: [Char] -> Action (Map ModuleName [Char])
loadPackageDb [Char]
fn = do
    Partial => [[Char]] -> Action ()
Shake.need [[Char]
fn]
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO forall a b. (a -> b) -> a -> b
$ do
        Either [Char] (Map ModuleName [Char])
result <- forall a. Serialize a => ModuleName -> Either [Char] a
Serialize.decode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ModuleName
B.readFile [Char]
fn
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadIO m => [Char] -> m a
Util.errorIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char]
"load from " forall a. [a] -> [a] -> [a]
++ [Char]
fn forall a. [a] -> [a] -> [a]
++ [Char]
":")++)) forall (m :: * -> *) a. Monad m => a -> m a
return Either [Char] (Map ModuleName [Char])
result

-- | Call 'getModuleToPackage' and save its contents to the file.
-- If there are colliding modules, throw an IO exception.
savePackageDb :: [Package] -> FilePath -> IO ()
savePackageDb :: [[Char]] -> [Char] -> IO ()
savePackageDb [[Char]]
packages [Char]
cacheFn = do
    (Map ModuleName [Char]
packageDb, [(ModuleName, [[Char]])]
collisions) <- [[Char]] -> IO (Map ModuleName [Char], [(ModuleName, [[Char]])])
getModuleToPackage [[Char]]
packages
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, [[Char]])]
collisions) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => [Char] -> m a
Util.errorIO forall a b. (a -> b) -> a -> b
$ [Char]
"modules found in >1 package:\n" forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines
            [ModuleName -> [Char]
B.unpack ModuleName
k forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
vs | (ModuleName
k, [[Char]]
vs) <- [(ModuleName, [[Char]])]
collisions]
    [Char] -> ModuleName -> IO ()
B.writeFile [Char]
cacheFn forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ModuleName
Serialize.encode Map ModuleName [Char]
packageDb

getModuleToPackage :: [Package]
    -> IO (Map.Map ModuleName Package, [(ModuleName, [Package])])
    -- ^ also return any modules found under multiple packages
getModuleToPackage :: [[Char]] -> IO (Map ModuleName [Char], [(ModuleName, [[Char]])])
getModuleToPackage [[Char]]
packages = do
    [([Char], [ModuleName])]
packageMods <- forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
packages forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Char] -> IO [ModuleName]
getExposedModules [[Char]]
packages
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k v. Ord k => [(k, v)] -> (Map k v, [(k, [v])])
Maps.unique2
        [(ModuleName
mod, [Char]
package) | ([Char]
package, [ModuleName]
mods) <- [([Char], [ModuleName])]
packageMods, ModuleName
mod <- [ModuleName]
mods]

getExposedModules :: Package -> IO [ModuleName]
getExposedModules :: [Char] -> IO [ModuleName]
getExposedModules [Char]
package =
    ModuleName -> [ModuleName]
parse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [[Char]] -> IO ModuleName
processStdout [Char]
"ghc-pkg" [[Char]
"field", [Char]
package, [Char]
"exposed-modules"]
    where
    -- The first word is "exposed-modules:".
    -- TODO gets duplicates if you have the same package installed under
    -- different versions.
    parse :: ModuleName -> [ModuleName]
parse = forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [ModuleName]
B.words

-- | Like 'importsOf' but transitive.  Includes the given module.
--
-- TODO Technically I should run CPP on the output of hsc2hs, which means
-- this should map the module names to the appropriate .hs and 'need' it.
-- Otherwise the '#include' that belongs to hsc2hs will get processed by CPP.
transitiveImportsOf :: Generated -> (FilePath -> Maybe [String])
    -> FilePath -> Shake.Action [FilePath]
transitiveImportsOf :: Generated
-> ([Char] -> Maybe [[Char]]) -> [Char] -> Action [[Char]]
transitiveImportsOf Generated
generated [Char] -> Maybe [[Char]]
cppFlagsOf [Char]
fn = do
    Partial => [[Char]] -> Action ()
Shake.need [[Char]
fn]
    Set [Char] -> [[Char]] -> Action [[Char]]
go forall a. Set a
Set.empty [[Char]
fn]
    where
    go :: Set [Char] -> [[Char]] -> Action [[Char]]
go Set [Char]
checked ([Char]
fn:[[Char]]
fns)
        | [Char]
fn forall a. Ord a => a -> Set a -> Bool
`Set.member` Set [Char]
checked = Set [Char] -> [[Char]] -> Action [[Char]]
go Set [Char]
checked [[Char]]
fns
        | Bool
otherwise = do
            [[Char]]
imports <- Generated -> Maybe [[Char]] -> [Char] -> Action [[Char]]
importsOf Generated
generated ([Char] -> Maybe [[Char]]
cppFlagsOf [Char]
fn) [Char]
fn
            let checked' :: Set [Char]
checked' = forall a. Ord a => a -> Set a -> Set a
Set.insert [Char]
fn Set [Char]
checked
            Set [Char] -> [[Char]] -> Action [[Char]]
go Set [Char]
checked' ([[Char]]
fns forall a. [a] -> [a] -> [a]
++ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set [Char]
checked') [[Char]]
imports)
    go Set [Char]
checked [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set [Char]
checked

fileOf :: Generated -> ModuleName -> IO (Maybe FilePath)
fileOf :: Generated -> ModuleName -> IO (Maybe [Char])
fileOf Generated
generated ModuleName
mod
    | [Char]
fn forall a. Ord a => a -> Set a -> Bool
`Set.member` Generated -> Set [Char]
_generatedHs Generated
generated = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Char]
fn
    | Bool
otherwise = [[Char]] -> IO (Maybe [Char])
findExistingFile forall a b. (a -> b) -> a -> b
$
        [Char]
fn forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> ShowS
FilePath.replaceExtension [Char]
fn) (Generated -> [[Char]]
_generatedExtensions Generated
generated)
    where
    fn :: [Char]
fn = ModuleName -> [Char]
B.unpack forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ModuleName -> ModuleName
B.map Char -> Char
slash ModuleName
mod forall a. Semigroup a => a -> a -> a
<> ModuleName
".hs"
    slash :: Char -> Char
slash Char
c = if Char
c forall a. Eq a => a -> a -> Bool
== Char
'.' then Char
'/' else Char
c

-- | Any line that starts with @import@ should be an import.  It's a reserved
-- word so I think that's safe?
parseImports :: B.ByteString -> [ModuleName]
parseImports :: ModuleName -> [ModuleName]
parseImports = forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (forall {a}. (Eq a, IsString a) => [a] -> Maybe a
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [ModuleName]
B.words) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [ModuleName]
B.lines
    where
    parse :: [a] -> Maybe a
parse (a
"import" : a
"qualified" : a
mod : [a]
_) = forall a. a -> Maybe a
Just a
mod
    parse (a
"import" : a
mod : [a]
_) = forall a. a -> Maybe a
Just a
mod
    parse [a]
_ = forall a. Maybe a
Nothing

-- | Read the file, and preprocess with CPPHS if cppFlags are given.
preprocess :: Maybe [String] -> FilePath -> IO B.ByteString
preprocess :: Maybe [[Char]] -> [Char] -> IO ModuleName
preprocess Maybe [[Char]]
Nothing [Char]
fn = [Char] -> IO ModuleName
B.readFile [Char]
fn
preprocess (Just [[Char]]
flags) [Char]
fn = [Char] -> [[Char]] -> IO ModuleName
processStdout [Char]
"cpphs" ([Char]
"--cpp" forall a. a -> [a] -> [a]
: [[Char]]
flags forall a. [a] -> [a] -> [a]
++ [[Char]
fn])


-- * util

processStdout :: FilePath -> [String] -> IO B.ByteString
processStdout :: [Char] -> [[Char]] -> IO ModuleName
processStdout [Char]
cmd [[Char]]
args = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket IO Handle
open Handle -> IO ()
IO.hClose Handle -> IO ModuleName
B.hGetContents
    where
    open :: IO Handle
open = do
        (Maybe Handle
_, Just Handle
stdout, Maybe Handle
_, ProcessHandle
_) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
loggedProcess forall a b. (a -> b) -> a -> b
$
            ([Char] -> [[Char]] -> CreateProcess
Process.proc [Char]
cmd [[Char]]
args) { std_out :: StdStream
Process.std_out = StdStream
Process.CreatePipe }
        forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout

-- | Like 'Process.createProcess', but actually report when the binary isn't
-- found.
loggedProcess :: Process.CreateProcess -> IO (Maybe IO.Handle,
       Maybe IO.Handle, Maybe IO.Handle, Process.ProcessHandle)
loggedProcess :: CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
loggedProcess CreateProcess
create = do
    r :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
r@(Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
pid) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess CreateProcess
create
    IO () -> IO ThreadId
Concurrent.forkIO forall a b. (a -> b) -> a -> b
$ do
        ExitCode
code <- ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
pid
        case ExitCode
code of
            Exit.ExitFailure Int
c -> Handle -> [Char] -> IO ()
IO.hPutStrLn Handle
IO.stderr forall a b. (a -> b) -> a -> b
$
                [Char]
"subprocess " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (CreateProcess -> [Char]
binaryOf CreateProcess
create) forall a. [a] -> [a] -> [a]
++ [Char]
" failed: "
                forall a. [a] -> [a] -> [a]
++ if Int
c forall a. Eq a => a -> a -> Bool
== Int
127 then [Char]
"binary not found" else forall a. Show a => a -> [Char]
show Int
c
            ExitCode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
r
    where
    binaryOf :: CreateProcess -> [Char]
binaryOf CreateProcess
create = case CreateProcess -> CmdSpec
Process.cmdspec CreateProcess
create of
        Process.RawCommand [Char]
fn [[Char]]
_ -> [Char]
fn
        Process.ShellCommand [Char]
cmd -> forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
' ') [Char]
cmd

findExistingFile :: [FilePath] -> IO (Maybe FilePath)
findExistingFile :: [[Char]] -> IO (Maybe [Char])
findExistingFile ([Char]
fn:[[Char]]
fns) =
    forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
Util.ifM ([Char] -> IO Bool
Directory.doesFileExist [Char]
fn) (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [Char]
fn))
        ([[Char]] -> IO (Maybe [Char])
findExistingFile [[Char]]
fns)
findExistingFile [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing