-- | 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.PreProcess.Types (Suffix (..))
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

    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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ModuleName -> IO (Maybe FilePath)
findCHS [ModuleName]
preMods

    modDeps <- traverse (extractDeps v) (zip preMods chsFiles)

    pure $ fmap (\(N ModuleName
m ModuleName
_ [ModuleName]
_) -> ModuleName
m) (revTopSort $ fromDistinctList modDeps)

        where findCHS :: ModuleName -> IO (Maybe FilePath)
findCHS = [Suffix] -> [FilePath] -> FilePath -> IO (Maybe FilePath)
findFileWithExtension [FilePath -> Suffix
Suffix 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 a. a -> IO a
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
    res <- FilePath -> IO (Either FilePath [FilePath])
getFileImports FilePath
f
    mods <- case 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse FilePath -> Maybe ModuleName
forall a. Parsec a => FilePath -> Maybe a
simpleParsec [FilePath]
ms of
            Just [ModuleName]
ms' -> [ModuleName] -> IO [ModuleName]
forall a. a -> IO a
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
$> []
    pure (N m m mods)