{-# LANGUAGE DataKinds #-}

-- | 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)
import           Distribution.Parsec                  (simpleParsec)
import           Distribution.Simple.PreProcess.Types (Suffix (..))
import           Distribution.Utils.Path               (FileOrDir (..), Pkg, Source, (</>),
                                                        SymbolicPath,
                                                        interpretSymbolicPathCWD)
import           Distribution.Simple.Utils            (findModuleFileEx,
                                                       warn)
import           Distribution.Verbosity               (Verbosity)
import           Language.Haskell.CHs.Deps            (getFileImports)

type CabalDir = SymbolicPath Pkg (Dir Source)

-- | Given a list of 'ModuleName's, sort it according to @c2hs@ @{\#import\#}@
-- declarations.
reorderC2Hs :: Verbosity
            -> [CabalDir] -- ^ Source directories
            -> [ModuleName] -- ^ Module names
            -> IO [ModuleName] -- ^ Sorted modules
reorderC2Hs :: Verbosity
-> [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
-> [ModuleName]
-> IO [ModuleName]
reorderC2Hs Verbosity
v [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
dirs [ModuleName]
preMods = do

    [FilePath]
chsFiles <- (ModuleName -> IO FilePath) -> [ModuleName] -> IO [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 (((SymbolicPathX 'AllowAbsolute Pkg ('Dir Source),
  RelativePath Source 'File)
 -> FilePath)
-> IO
     (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source),
      RelativePath Source 'File)
-> IO FilePath
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SymbolicPathX 'AllowAbsolute Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
interpretSymbolicPathCWD (SymbolicPathX 'AllowAbsolute Pkg 'File -> FilePath)
-> ((SymbolicPathX 'AllowAbsolute Pkg ('Dir Source),
     RelativePath Source 'File)
    -> SymbolicPathX 'AllowAbsolute Pkg 'File)
-> (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source),
    RelativePath Source 'File)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)
 -> RelativePath Source 'File
 -> SymbolicPathX 'AllowAbsolute Pkg 'File)
-> (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source),
    RelativePath Source 'File)
-> SymbolicPathX 'AllowAbsolute Pkg 'File
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)
-> RelativePath Source 'File
-> SymbolicPathX 'AllowAbsolute Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
(</>)) (IO
   (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source),
    RelativePath Source 'File)
 -> IO FilePath)
-> (ModuleName
    -> IO
         (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source),
          RelativePath Source 'File))
-> ModuleName
-> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName
-> IO
     (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source),
      RelativePath Source 'File)
findCHS) [ModuleName]
preMods

    [Node ModuleName ModuleName]
modDeps <- ((ModuleName, FilePath) -> IO (Node ModuleName ModuleName))
-> [(ModuleName, FilePath)] -> IO [Node ModuleName 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 (Verbosity
-> (ModuleName, FilePath) -> IO (Node ModuleName ModuleName)
extractDeps Verbosity
v) ([ModuleName] -> [FilePath] -> [(ModuleName, FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
preMods [FilePath]
chsFiles)

    [ModuleName] -> IO [ModuleName]
forall a. a -> IO a
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 a b. (a -> b) -> [a] -> [b]
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
     (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source),
      RelativePath Source 'File)
findCHS = Verbosity
-> [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
-> [Suffix]
-> ModuleName
-> IO
     (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source),
      RelativePath Source 'File)
forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [Suffix]
-> ModuleName
-> IO
     (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
      RelativePath searchDir 'File)
findModuleFileEx Verbosity
v [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
dirs [FilePath -> Suffix
Suffix FilePath
".chs"]

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