module Distribution.C2Hs.TopSort ( reorderC2Hs ) where
import Control.Applicative (pure)
import Data.Functor (($>))
import Data.Traversable (traverse)
import Distribution.Compat.Graph (Node (..), fromDistinctList,
revTopSort)
import Distribution.ModuleName (ModuleName, toFilePath)
import Distribution.Parsec (simpleParsec)
import Distribution.Simple.Utils (findFileWithExtension, warn)
import Distribution.Verbosity (Verbosity)
import Language.Haskell.CHs.Deps (getFileImports)
reorderC2Hs :: Verbosity
-> [FilePath]
-> [ModuleName]
-> IO [ModuleName]
reorderC2Hs :: Verbosity -> [FilePath] -> [ModuleName] -> IO [ModuleName]
reorderC2Hs Verbosity
v [FilePath]
dirs [ModuleName]
preMods = do
[Maybe FilePath]
chsFiles <- (ModuleName -> IO (Maybe FilePath))
-> [ModuleName] -> IO [Maybe FilePath]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ModuleName -> IO (Maybe FilePath)
findCHS [ModuleName]
preMods
[Node ModuleName ModuleName]
modDeps <- ((ModuleName, Maybe FilePath) -> IO (Node ModuleName ModuleName))
-> [(ModuleName, Maybe FilePath)]
-> IO [Node ModuleName ModuleName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Verbosity
-> (ModuleName, Maybe FilePath) -> IO (Node ModuleName ModuleName)
extractDeps Verbosity
v) ([ModuleName] -> [Maybe FilePath] -> [(ModuleName, Maybe FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
preMods [Maybe FilePath]
chsFiles)
[ModuleName] -> IO [ModuleName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleName] -> IO [ModuleName])
-> [ModuleName] -> IO [ModuleName]
forall a b. (a -> b) -> a -> b
$ (Node ModuleName ModuleName -> ModuleName)
-> [Node ModuleName ModuleName] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(N ModuleName
m ModuleName
_ [ModuleName]
_) -> ModuleName
m) (Graph (Node ModuleName ModuleName) -> [Node ModuleName ModuleName]
forall a. Graph a -> [a]
revTopSort (Graph (Node ModuleName ModuleName)
-> [Node ModuleName ModuleName])
-> Graph (Node ModuleName ModuleName)
-> [Node ModuleName ModuleName]
forall a b. (a -> b) -> a -> b
$ [Node ModuleName ModuleName] -> Graph (Node ModuleName ModuleName)
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
fromDistinctList [Node ModuleName ModuleName]
modDeps)
where findCHS :: ModuleName -> IO (Maybe FilePath)
findCHS = [FilePath] -> [FilePath] -> FilePath -> IO (Maybe FilePath)
findFileWithExtension [FilePath
".chs"] [FilePath]
dirs (FilePath -> IO (Maybe FilePath))
-> (ModuleName -> FilePath) -> ModuleName -> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> FilePath
toFilePath
extractDeps :: Verbosity -> (ModuleName, Maybe FilePath) -> IO (Node ModuleName ModuleName)
Verbosity
_ (ModuleName
m, Maybe FilePath
Nothing) = Node ModuleName ModuleName -> IO (Node ModuleName ModuleName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleName
-> ModuleName -> [ModuleName] -> Node ModuleName ModuleName
forall k a. a -> k -> [k] -> Node k a
N ModuleName
m ModuleName
m [])
extractDeps Verbosity
v (ModuleName
m, Just FilePath
f) = do
Either FilePath [FilePath]
res <- FilePath -> IO (Either FilePath [FilePath])
getFileImports FilePath
f
[ModuleName]
mods <- case Either FilePath [FilePath]
res of
Right [FilePath]
ms -> case (FilePath -> Maybe ModuleName) -> [FilePath] -> Maybe [ModuleName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> Maybe ModuleName
forall a. Parsec a => FilePath -> Maybe a
simpleParsec [FilePath]
ms of
Just [ModuleName]
ms' -> [ModuleName] -> IO [ModuleName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ModuleName]
ms'
Maybe [ModuleName]
Nothing -> Verbosity -> FilePath -> IO ()
warn Verbosity
v (FilePath
"Cannot parse module name in .chs file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f) IO () -> [ModuleName] -> IO [ModuleName]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
Left FilePath
err -> Verbosity -> FilePath -> IO ()
warn Verbosity
v (FilePath
"Cannot parse c2hs import in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err) IO () -> [ModuleName] -> IO [ModuleName]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
Node ModuleName ModuleName -> IO (Node ModuleName ModuleName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleName
-> ModuleName -> [ModuleName] -> Node ModuleName ModuleName
forall k a. a -> k -> [k] -> Node k a
N ModuleName
m ModuleName
m [ModuleName]
mods)