cabal-sort-0.0.1: src/Main.hs

module Main where

import qualified Distribution.PackageDescription as P
import Distribution.PackageDescription
         (GenericPackageDescription, PackageDescription,
          package, packageDescription, buildDepends, )
import Distribution.PackageDescription.Parse (readPackageDescription, )
import Distribution.Package
         (Dependency(Dependency), PackageName(PackageName), pkgName, )

import qualified Distribution.Verbosity as Verbosity
import qualified Distribution.ReadE as ReadE

import System.Console.GetOpt
          (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )
import System.Exit (exitWith, ExitCode(..), )
import qualified System.Environment as Env
import qualified System.FilePath as FilePath

import Data.Graph.Inductive.Query.DFS (topsort', scc, )
import Data.Graph.Inductive.Tree (Gr, )
import qualified Data.Graph.Inductive.Graph as Graph

import qualified Control.Monad.Exception.Synchronous as Exc
import qualified Control.Monad.Trans.Class as Trans

import qualified Data.Set as Set
import Control.Monad (when, )
import Data.Maybe (mapMaybe, )


main :: IO ()
main =
   Exc.resolveT (\e -> putStr $ "Aborted: " ++ e ++ "\n") $ do
      argv <- Trans.lift Env.getArgs
      let (opts, cabalPaths, errors) =
             getOpt RequireOrder options argv
      when (not (null errors)) $ Exc.throwT $ concat $ errors
      flags <-
         Exc.ExceptionalT $ return $
            foldr (flip (>>=))
               (return $
                Flags {optHelp = False,
                       optVerbosity = Verbosity.silent,
                       optInfo = location})
               opts
      when (optHelp flags)
         (Trans.lift $
          Env.getProgName >>= \programName ->
          putStrLn
             (usageInfo ("Usage: " ++ programName ++
                         " [OPTIONS] CABAL-FILES ...") options) >>
          exitWith ExitSuccess)

      Trans.lift $ sortCabalFiles flags cabalPaths


data Flags =
   Flags {
      optHelp :: Bool,
      optVerbosity :: Verbosity.Verbosity,
      optInfo :: SourcePackage -> String
   }

options :: [OptDescr (Flags -> Exc.Exceptional String Flags)]
options =
   Option ['h'] ["help"]
      (NoArg (\flags -> return $ flags{optHelp = True}))
      "show options" :
   Option ['v'] ["verbose"]
      (ReqArg
         (\str flags ->
            fmap (\n -> flags{optVerbosity = n}) $
            Exc.fromEither $
            ReadE.runReadE Verbosity.flagToVerbosity str)
         "N")
      "verbosity level: 0..3" :
   Option [] ["info"]
      (ReqArg
         (\str flags ->
            fmap (\select -> flags{optInfo = select}) $
            case str of
               "name" -> Exc.Success
                            (getPkgName . pkgName . package .
                             packageDescription . description)
               "path" -> Exc.Success location
               "dir"  -> Exc.Success (FilePath.takeDirectory . location)
               _ ->
                  Exc.Exception $
                  "unknown info type " ++ str)
         "KIND")
      "kind of output: name, path, dir" :
   []



data SourcePackage =
   SourcePackage {
      location :: FilePath,
      description :: GenericPackageDescription
   }

sortCabalFiles :: Flags -> [FilePath] -> IO ()
sortCabalFiles flags cabalPaths =
   do pkgDescs <-
         mapM (readPackageDescription (optVerbosity flags)) cabalPaths
      when (optVerbosity flags >= Verbosity.verbose) $
         flip mapM_ pkgDescs $ \pkgDesc -> do
            putStrLn
               ((getPkgName . pkgName . package . packageDescription $ pkgDesc) ++ ":")
            let deps =
                   Set.toAscList $ Set.fromList $
                   map (getPkgName . depName) $
                   allDependencies pkgDesc
            flip mapM_ deps $ \dep ->
               putStrLn $ "  " ++ dep
      mapM_ (putStrLn . optInfo flags) $
         getBuildOrder $
         zipWith SourcePackage cabalPaths pkgDescs


getBuildOrder ::
   [SourcePackage] ->
   [SourcePackage]
getBuildOrder srcPkgs =
   let nodes = zip [0..] srcPkgs
       nodeDict =
          zip
             (map (pkgName . package . packageDescription . description)
                  srcPkgs)
             [0..]
       edges = do
          (srcNode,desc) <- nodes
          dstNode <-
             mapMaybe
                (flip lookup nodeDict . depName)
                (allDependencies $ description desc)
          return (dstNode, srcNode, ())
       graph :: Gr SourcePackage ()
       graph = Graph.mkGraph nodes edges

   in  if hasCycle graph
         then error "cycle in dependencies"
         else topsort' graph

allDependencies :: GenericPackageDescription -> [Dependency]
allDependencies pkg =
   P.buildDepends (packageDescription pkg) ++
   maybe [] (concatMap snd . flattenCondTree) (P.condLibrary pkg) ++
   concatMap (concatMap snd . flattenCondTree . snd) (P.condExecutables pkg)

flattenCondTree :: P.CondTree v c a -> [(a,c)]
flattenCondTree tree =
   (P.condTreeData tree, P.condTreeConstraints tree) :
   concatMap
      (\(_, thenBranch, elseBranch) ->
         flattenCondTree thenBranch ++
         maybe [] flattenCondTree elseBranch)
      (P.condTreeComponents tree)

depName :: Dependency -> PackageName
depName (Dependency name _) = name

getPkgName :: PackageName -> String
getPkgName (PackageName name) = name

hasCycle :: Gr a b -> Bool
hasCycle graph =
   length (scc graph) < length (Graph.nodes graph)