{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}

-- | TAG a stack project based on snapshot versions

module Stack.Tag where

import qualified Data.Set          as Set
import qualified Data.Text         as T
import qualified Data.Traversable  as T

import Control.Exception    as E
import Control.Monad.Reader
import Data.Either
import Data.Maybe
import Data.Text            (Text)
import System.Directory
import System.Exit
import System.Process

import Control.Concurrent.Async.Pool


data StackTagOpts = StackTagOpts {

      -- | Location of the stack.yaml to generate tags for
      optsStackYaml :: !(Maybe FilePath)

      -- | Verbose output
    , optsVerbose   :: !Bool

      -- | Flag to ignore any cached tags and re-run the tagger
    , noCache       :: !Bool

    } deriving Show


data Tagger = Hasktags
            | HotHasktags
            | OtherTagger Text
            deriving Show

data TagFmt = CTags
            | ETags
            | Both
            | OtherFmt Text
            deriving Show

type TagOutput = FilePath
type SourceDir = FilePath
type PkgName = String

data TagCmd = TagCmd Tagger TagFmt TagOutput SourceDir PkgName deriving Show

newtype StackTag a = StackTag {
    runStackTag :: ReaderT StackTagOpts IO a
  } deriving (
               Functor
             , Applicative
             , Monad
             , MonadReader StackTagOpts
             , MonadIO
             )

defStackOpts :: StackTagOpts
defStackOpts = StackTagOpts Nothing False True

stackTag :: StackTagOpts -> IO ()
stackTag = runReaderT (runStackTag app)
 where
  app = do chkStackCompatible
           chkHaskTags
           chkIsStack
           sources     <- stkPaths
           depSources  <- stkDepSources
           tagSources sources depSources

--------------------------------------------------------------------------
--------------------------------------------------------------------------

io :: MonadIO m => IO a -> m a
io = liftIO

p :: String -> StackTag ()
p msg = whenM (ask >>= pure . optsVerbose) $ io (putStrLn msg)

whenM :: Monad m => m Bool -> m () -> m ()
whenM predicate go = predicate >>= flip when go

-- | Run a command using the `stack' command-line tool
-- with a list of arguments
runStk :: [String] -> StackTag (ExitCode, String, String)
runStk args = io $ readProcessWithExitCode "stack" args []

chkIsStack :: StackTag ()
chkIsStack = do
  StackTagOpts {optsStackYaml=stackYaml} <- ask
  sYaml <- io $ doesFileExist "stack.yaml"

  case stackYaml of
    Nothing -> unless sYaml $ error "stack.yaml not found or specified!"
    _       -> return ()

chkHaskTags :: StackTag ()
chkHaskTags = do
  ht <- io $ findExecutable "hasktags"
  case ht of
    Just _p -> return ()
    Nothing -> error "You must have hasktags installed Run 'stack install hasktags'."

--- | Check whether the current version of stack
-- is compatible by trying to run `stack list-depenencies --help`.
chkStackCompatible :: StackTag ()
chkStackCompatible = do
  (exitc, _, _) <- runStk ["ls", "dependencies", "--help"]
  case exitc of
    ExitSuccess    -> return ()
    ExitFailure _e ->
      p (show exitc) >> error "You need stack version 1.7.1 or higher installed and in your PATH to use stack-tag"

-- | Get a list of relavant directories from stack using
-- the @stack path@ command
stkPaths :: StackTag [(Text,[Text])]
stkPaths = do
    (_,ps,_) <- runStk ["path"]
    return (parsePaths ps)
  where
    parsePaths = map parsePath . T.lines . T.pack
    parsePath ps = let (k,vs) = T.breakOn ":" ps
                   in (k, splitAndStrip vs)
    splitAndStrip = filter (not . T.null) . map T.strip . T.splitOn ":"

-- | Get a list of dependencies using:
-- @stack --list-dependencies --test --bench --separator=-@
stkDepSources :: StackTag [String]
stkDepSources = do
  (_exitc,ls,_) <- runStk [ "ls", "dependencies", "--external"
                               , "--include-base", "--test"
                               , "--bench", "--separator=-"]
  return $ lines ls

--------------------------------------------------------------------------
--------------------------------------------------------------------------

tagSources :: [(Text,[Text])] -> [FilePath] -> StackTag ()
tagSources srcs depsrcs = do

  let srcDir    = lookup "project-root" srcs
  let tagroot   = T.unpack . fromMaybe "." . listToMaybe . fromMaybe [] $ srcDir

  -- alternative pooled
  depTagFiles <- parTag srcs depsrcs

  -- map a tag command over all provided sources
  thisProj   <- runTagger (TagCmd Hasktags ETags "stack.tags" tagroot "project-root")
  taggedSrcs <- T.traverse (io . readFile) (rights (thisProj : depTagFiles))

  let errors = lefts (thisProj : depTagFiles)
  unless (null errors) $ do

      let pkg_errs = map (\(pkg,err) -> pkg ++ ": " ++ err) $ take 10 errors
      error $ unlines $
                   "[tag:error] stack-tag encountered errors creating tags"
                 : pkg_errs

  let xs = concatMap lines taggedSrcs
      ys = if False then (Set.toList . Set.fromList) xs else xs

  p $ "[tag:done] built & merged tags for " ++ show (length taggedSrcs) ++ " projects"
  io $ writeFile "TAGS" $ unlines ys

parTag :: [(Text, [Text])] -> [FilePath] -> StackTag [Either (PkgName, String) FilePath]
parTag srcs depsrcs = do

  o@StackTagOpts {noCache=nocache} <- ask

  -- control the number of jobs by using capabilities Currently,
  -- capabilities creates a few too many threads which saturates the
  -- CPU and network connection. For now, it's manually set to 3 until
  -- a better threading story is figured out.
  --
  -- io $ mapCapabilityPool (tagDependency nocache srcs) depsrcs

  -- WAT: rewrap the transformer. It's less heavy duty than bringing in
  -- monad-control or refactoring (2018-09-14)
  let worker osrc = flip runReaderT o $ do
          runStackTag (tagDependency nocache srcs osrc)

  io $ mapPool 3 worker depsrcs

-- | Tag a single dependency
tagDependency :: Bool -> [(Text, [Text])] -> FilePath -> StackTag (Either (PkgName, String) FilePath)
tagDependency nocache stkpaths dep = do

    let snapRoot
            | Just (sr : _) <- lookup "snapshot-install-root" stkpaths = sr
            | otherwise = error ("[tag:error] error tagging "
                               ++ dep
                               ++ ". "
                               ++ "No 'snapshot-install-root' found, aborting.")
        dir          = T.unpack snapRoot ++ "/packages" ++ "/" ++ dep
        tagFile      = dir ++ "/TAGS"

    -- HACK as of Aug 5 2015, `stack unpack` can only download sources
    -- into the current directory. Therefore, we move the source to
    -- the correct snapshot location. This could/should be fixed in
    -- the stack source (especially since --haddock has similar
    -- behavior). A quick solution to avoid this might be to run the
    -- entire function in the target directory
    _ <- io $ readProcess "rm" ["--preserve-root", "-rf", dep] []

    -- error (show dep)

    exists <- io $ doesDirectoryExist dir
    tagged <- io $ doesFileExist tagFile

    unless exists $ void $ do
        io $ createDirectoryIfMissing True dir
        p $ "[tag:download] " ++ dep
        (ec,stout,_) <- runStk ["unpack", dep]
        case ec of
          ExitFailure _ -> void $ do
              p $ "[tag:download] failed to download " ++ dep ++ " - " ++ stout
          ExitSuccess   -> void $ do
              p $ "[tag:download] cp " ++ dep ++ " to snapshot source cache in " ++ dir
              io $ readProcess "mv" [dep,dir] []

    if tagged && nocache
       then do p $ "[tag:nocache] " ++ dep
               return (Right tagFile)
       else do p $ "[tag:cache] " ++ dep
               runTagger (TagCmd Hasktags ETags tagFile dir dep)

runTagger :: TagCmd -> StackTag (Either (PkgName, String) TagOutput)
runTagger (TagCmd t fmt to fp dep) = do

    let opts = [ tagFmt fmt
               , "-R"  -- tags-absolute
               -- made the default & removed
               -- , "--ignore-close-implementation"
              , "--follow-symlinks"
              -- , "--cache"
              , "--output"
              , to
              , fp
              ]

    (ec, stout, err) <- hasktags opts

    case ec of
        ExitFailure _
            | null err -> return $ Left (dep, stout)
            | otherwise -> return $ Left (dep, err)
        ExitSuccess   -> return $ Right to
  where
    hasktags opts = io $
        readProcessWithExitCode (tagExe t) opts []
          `E.catch` (\(SomeException err) -> return (ExitFailure 1, displayException err, ""))


-- TODO tagExe Hasktags   = "fast-tags"
tagExe :: Tagger -> String
tagExe Hasktags   = "hasktags"
tagExe _          = error "Tag command not supported. Feel free to create an issue at https://github.com/creichert/stack-tag"

tagFmt :: TagFmt -> String
tagFmt ETags   = "--etags"
tagFmt CTags   = "--etags"
tagFmt Both    = "--both"
tagFmt _       = error "Tag format not supported. Feel free to create an issue at https://github.com/creichert/stack-tag"