-- | Topological sort for @.chs@ files according to @{\#import\#}@s.
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)

-- | Given a list of 'ModuleName's, sort it according to @c2hs@ @{\#import\#}@
-- declarations.
reorderC2Hs :: Verbosity
            -> [FilePath] -- ^ Source directories
            -> [ModuleName] -- ^ Module names
            -> IO [ModuleName] -- ^ Sorted modules
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

-- | Given a 'ModuleName' and its corresponding filepath, return a 'Node'
-- with its associated @c2hs@ dependencies
extractDeps :: Verbosity -> (ModuleName, Maybe FilePath) -> IO (Node ModuleName ModuleName)
extractDeps :: Verbosity
-> (ModuleName, Maybe FilePath) -> IO (Node ModuleName ModuleName)
extractDeps 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)