TopSort.hs

{-# 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 v dirs preMods = do

    chsFiles <- traverse (fmap (interpretSymbolicPathCWD . uncurry (</>)) . findCHS) preMods

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

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

        where findCHS = findModuleFileEx v dirs [Suffix ".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 v (m, f) = do
    res <- getFileImports f
    mods <- case res of
        Right ms -> case traverse simpleParsec ms of
            Just ms' -> pure ms'
            Nothing -> warn v ("Cannot parse module name in .chs file " ++ f) $> []
        Left err -> warn v ("Cannot parse c2hs import in " ++ f ++ ": " ++ err) $> []
    pure (N m m mods)