{-# LANGUAGE LambdaCase #-}

module Main where

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

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

import System.Directory (doesDirectoryExist, doesFileExist,
#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5))
                         listDirectory
#else
                         getDirectoryContents
#endif
  )
import System.IO (hPutStrLn, stderr)
import System.Process (readProcess)

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

import qualified Control.Monad.Exception.Synchronous as E
import qualified Control.Monad.Trans.Class as T

import qualified Data.Set as Set
import Control.Monad (guard, when, unless)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.List (delete, intersperse, stripPrefix)

#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,2))
#else
import Control.Applicative ((<$>))
#endif

#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5))
#else
listDirectory :: FilePath -> IO [FilePath]
listDirectory path =
  filter f <$> getDirectoryContents path
  where f filename = filename /= "." && filename /= ".."
#endif

main :: IO ()
main =
  E.resolveT handleException $ do
  argv <- T.lift Env.getArgs
  let (opts, args, errors) = getOpt Permute options argv
  if length args < 2
    then T.lift $ help >> exitFailure
    else do
      let (com:pkgs) = args
      unless (null errors) $ E.throwT $ concat errors
      unless (com `elem` ["sort", "deps", "rdeps"]) $
        E.throwT $ "Unknown command " ++ com
      flags <-
         E.ExceptionalT $ return $
            foldr (=<<)
               (return
                Flags {optHelp = False,
                       optVerbosity = Verbosity.silent,
                       optFormat = package,
                       optParallel = Nothing,
                       optBranch = Nothing})
               opts
      if optHelp flags
        then T.lift $ help >> exitSuccess
        else runCommand flags com $ map (removeSuffix "/") pkgs
  where
    help =
      Env.getProgName >>= \programName ->
        putStrLn
             (usageInfo ("Usage: " ++ programName ++
                         " [OPTIONS] [sort|deps|rdeps] PKG-SPEC-OR-DIR ...") options)

handleException :: String -> IO ()
handleException msg = do
   putStrLn $ "Aborted: " ++ msg
   exitFailure

findSpec :: Maybe FilePath -> FilePath -> IO (Maybe FilePath)
findSpec mdir file =
  if takeExtension file == ".spec"
    then checkFile file
    else do
    dirp <- doesDirectoryExist file
    if dirp
      then
      let dir = maybe file (file </>) mdir
          pkg = takeBaseName file in
        checkFile $ dir </> pkg ++ ".spec"
      else return Nothing
  where
    checkFile :: FilePath -> IO (Maybe FilePath)
    checkFile f = do
      e <- doesFileExist f
      if e
        then return $ Just f
        else return Nothing

data Flags =
   Flags {
      optHelp :: Bool,
      optVerbosity :: Verbosity.Verbosity,
      optFormat :: SourcePackage -> String,
      optParallel :: Maybe String,
      optBranch :: Maybe FilePath
   }

options :: [OptDescr (Flags -> E.Exceptional String Flags)]
options =
  [
    Option ['h'] ["help"]
      (NoArg (\flags -> return $ flags{optHelp = True}))
      "Show options"
  , Option ['p'] ["parallel"]
      (OptArg
        (\mstr flags ->
            fmap (\cs -> flags{optParallel = Just cs})
            (E.Success (fromMaybe "" mstr)))
         "SEPARATOR")
      "Display independently buildable groups of packages, optionally with separator"
  , Option ['b'] ["branch"]
      (ReqArg
         (\str flags ->
            fmap (\mb -> flags{optBranch = mb})
            (E.Success (Just str)))
         "BRANCHDIR")
    "branch directory"
  , Option ['f'] ["format"]
      (ReqArg
         (\str flags ->
            fmap (\select -> flags{optFormat = select}) $
            case str of
               "package" -> E.Success package
               "spec" -> E.Success location
               "dir"  -> E.Success (takeDirectory . location)
               _ ->
                  E.Exception $
                  "unknown info type " ++ str)
         "KIND")
      "output format: 'package' (default), 'spec', or 'dir'"
  , Option ['v'] ["verbose"]
      (ReqArg
         (\str flags ->
            fmap (\n -> flags{optVerbosity = n}) $
            E.fromEither $
            ReadE.runReadE Verbosity.flagToVerbosity str)
         "N")
      "verbosity level: 0..3"
  ]

type Package = String

data SourcePackage =
   SourcePackage {
      location :: FilePath,
      package :: Package,
      dependencies :: [Package]
   }
   deriving (Show, Eq)

type Command = String

runCommand :: Flags -> Command -> [Package] -> E.ExceptionalT String IO ()
runCommand flags "sort" pkgs = sortSpecFiles flags pkgs
runCommand flags "deps" pkgs = depsSpecFiles False flags pkgs
runCommand flags "rdeps" pkgs = depsSpecFiles True flags pkgs
runCommand _ _ _ = E.throwT "impossible happened"

createGraphNodes :: Flags -> [Package] -> [Package] ->
               E.ExceptionalT String IO (Gr SourcePackage (), [Graph.Node])
createGraphNodes flags pkgs subset = do
  unless (all (`elem` pkgs) subset) $
    E.throwT "Packages must be in the current directory"
  specPaths <- T.lift $ catMaybes <$> mapM (findSpec (optBranch flags)) (filter (/= fromMaybe "" (optParallel flags)) pkgs)
  let names = map takeBaseName specPaths
  provs <-
     T.lift $
     mapM (readProvides (optVerbosity flags)) specPaths
  let resolves = zip names provs
  deps <-
     T.lift $
     mapM (getDepsSrcResolved (optVerbosity flags) resolves) specPaths
  let spkgs = zipWith3 SourcePackage specPaths names deps
      graph = getBuildGraph spkgs
  checkForCycles graph
  let nodes = Graph.labNodes graph
      subnodes = mapMaybe (pkgNode nodes) subset
  return (graph, subnodes)
  where
    pkgNode [] _ = Nothing
    pkgNode ((i,l):ns) p = if p == package l then Just i else pkgNode ns p

sortSpecFiles :: Flags -> [Package] -> E.ExceptionalT String IO ()
sortSpecFiles flags pkgs = do
      (graph, _) <- createGraphNodes flags pkgs []
      T.lift $
         case optParallel flags of
           Just s ->
             mapM_ ((putStrLn . unwords . (if null s then id else intersperse s) . map (optFormat flags)) . topsort' . subgraph graph)
                 (components graph)
           Nothing ->
             mapM_ (putStrLn . optFormat flags) $ topsort' graph
 
depsSpecFiles :: Bool -> Flags -> [Package] -> E.ExceptionalT String IO ()
depsSpecFiles rev flags pkgs = do
  allpkgs <- T.lift $ listDirectory "."
  (graph, nodes) <- createGraphNodes flags allpkgs pkgs
  let dir = if rev then Graph.suc' else Graph.pre'
  sortSpecFiles flags $ map package $ xdfsWith dir third nodes graph
  where
    third (_, _, c, _) = c

readProvides :: Verbosity.Verbosity -> FilePath -> IO [String]
readProvides verbose file = do
  when (verbose >= Verbosity.verbose) $ hPutStrLn stderr file
  pkgs <- lines <$>
    rpmspec ["--rpms", "--qf=%{name}\n", "--define", "ghc_version any"] Nothing file
  let pkg = takeBaseName file
  return $ delete pkg pkgs

getDepsSrcResolved :: Verbosity.Verbosity -> [(String,[String])] -> FilePath -> IO [String]
getDepsSrcResolved verbose provides file =
  map (resolveBase provides) <$> do
      when (verbose >= Verbosity.verbose) $ hPutStrLn stderr file
      -- ignore version bounds
      map (head . words) . lines <$>
        rpmspec ["--buildrequires", "--define", "ghc_version any"] Nothing file
  where
    resolveBase :: [(String,[String])] -> String -> String
    resolveBase provs br =
      case mapMaybe (\ (pkg,subs) -> if br `elem` subs then Just pkg else Nothing) provs of
        [] -> br
        [p] -> p
        ps -> error $ br ++ "is provided by: " ++ unwords ps

removeSuffix :: String -> String -> String
removeSuffix suffix orig =
  fromMaybe orig $ stripSuffix suffix orig
  where
    stripSuffix sf str = reverse <$> stripPrefix (reverse sf) (reverse str)

cmdStdIn :: String -> [String] -> String -> IO String
cmdStdIn c as inp = removeTrailingNewline <$> readProcess c as inp
  where
    removeTrailingNewline :: String -> String
    removeTrailingNewline "" = ""
    removeTrailingNewline str =
      if last str == '\n'
      then init str
      else str

cmd :: String -> [String] -> IO String
cmd c as = cmdStdIn c as ""

rpmspec :: [String] -> Maybe String -> FilePath -> IO String
rpmspec args mqf spec = do
  let qf = maybe [] (\ q -> ["--queryformat", q]) mqf
  cmd "rpmspec" (["-q"] ++ args ++ qf ++ [spec])

getDeps :: Gr SourcePackage () -> [(SourcePackage, [SourcePackage])]
getDeps gr =
    let c2dep :: Graph.Context SourcePackage () -> (SourcePackage, [SourcePackage])
        c2dep ctx =
           (Graph.lab' ctx,
            map (Graph.lab' . Graph.context gr) (Graph.pre gr . Graph.node' $ ctx))
    in  Graph.ufold (\ctx ds -> c2dep ctx : ds) [] gr

getBuildGraph :: [SourcePackage] -> Gr SourcePackage ()
getBuildGraph srcPkgs =
   let nodes = zip [0..] srcPkgs
       nodeDict = zip (map package srcPkgs) [0..]
       edges = do
          (srcNode,srcPkg) <- nodes
          dstNode <- mapMaybe (`lookup` nodeDict) (dependencies srcPkg)
          guard (dstNode /= srcNode)
          return (dstNode, srcNode, ())
   in Graph.mkGraph nodes edges

checkForCycles ::
   Monad m =>
   Gr SourcePackage () ->
   E.ExceptionalT String m ()
checkForCycles graph =
   case getCycles graph of
      [] -> return ()
      cycles ->
         E.throwT $ unlines $
         "Cycles in dependencies:" :
         map (unwords . map location . nodeLabels graph) cycles

nodeLabels :: Gr a b -> [Graph.Node] -> [a]
nodeLabels graph =
   map (fromMaybe (error "node not found in graph") .
        Graph.lab graph)

subgraph :: Gr a b -> [Graph.Node] -> Gr a b
subgraph graph nodes =
   let nodeSet = Set.fromList nodes
       edges = do
           from <- nodes
           (to, lab) <- Graph.lsuc graph from
           guard $ Set.member from nodeSet && Set.member to nodeSet
           return (from,to,lab)
   in  Graph.mkGraph (zip nodes $ nodeLabels graph nodes) edges

getCycles :: Gr a b -> [[Graph.Node]]
getCycles =
   filter (\case
              _:_:_ -> True
              _ -> False)
   . scc