{-# LANGUAGE TemplateHaskell, RankNTypes #-}

module HsDev.Stack (
	stack, yaml,
	path, pathOf,
	build, buildDeps,
	StackEnv(..), stackRoot, stackProject, stackConfig, stackGhc, stackSnapshot, stackLocal,
	getStackEnv, projectEnv,
	stackPackageDbStack,

	stackCompiler, stackArch,

	MaybeT(..)
	) where

import Control.Arrow
import Control.Lens (makeLenses, Lens', at, ix, lens, (^?), (^.))
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Data.Char
import Data.Maybe
import Data.Map.Strict (Map)
import Data.Version (showVersion)
import qualified Data.Map.Strict as M
import Distribution.Compiler
import Distribution.System
import qualified Distribution.Text as T (display)
import System.Directory
import System.Environment
import System.FilePath
import qualified System.Log.Simple as Log
import Text.Format (formats, (~%))

import qualified GHC
import qualified Packages as GHC

import HsDev.Error
import HsDev.PackageDb
import HsDev.Tools.Ghc.Worker (GhcM, tmpSession)
import qualified HsDev.Tools.Ghc.Compat as Compat
import HsDev.Util as Util
import HsDev.Tools.Base (runTool_)
import qualified System.Directory.Paths as P

-- | Get compiler version
stackCompiler :: GhcM String
stackCompiler = do
	tmpSession globalDb ["-no-user-package-db"]
	df <- GHC.getSessionDynFlags
	let
		res =
			map (GHC.packageNameString &&& GHC.packageVersion) .
			fromMaybe [] .
			Compat.pkgDatabase $ df
		compiler = T.display buildCompilerFlavor
		CompilerId _ version' = buildCompilerId
		ver = maybe (T.display version') showVersion $ lookup compiler res
	return $ compiler ++ "-" ++ ver

-- | Get arch for stack
stackArch :: String
stackArch = T.display buildArch

-- | Invoke stack command, we are trying to get actual stack near current hsdev executable
stack :: [String] -> GhcM String
stack cmd' = hsdevLiftIO $ do
	curExe <- liftIO getExecutablePath
	stackExe <- Util.withCurrentDirectory (takeDirectory curExe) $
		liftIO (findExecutable "stack") >>= maybe (hsdevError $ ToolNotFound "stack") return
	comp <- stackCompiler
	let
		args' = ["--compiler", comp, "--arch", stackArch] ++ cmd'
	Log.sendLog Log.Trace $ formats "invoking stack: {exe} {args}" [
		"exe" ~% stackExe,
		"args" ~% unwords args']
	liftIO $ runTool_ stackExe args'

-- | Make yaml opts
yaml :: Maybe FilePath -> [String]
yaml Nothing = []
yaml (Just y) = ["--stack-yaml", y]

type PathsConf = Map String FilePath

-- | Stack path
path :: Maybe FilePath -> GhcM PathsConf
path mcfg = liftM (M.fromList . map breakPath . lines) $ stack ("path" : yaml mcfg) where
	breakPath :: String -> (String, FilePath)
	breakPath = second (dropWhile isSpace . drop 1) . break (== ':')

-- | Get path for
pathOf :: String -> Lens' PathsConf (Maybe FilePath)
pathOf = at

-- | Build stack project
build :: [String] -> Maybe FilePath -> GhcM ()
build opts mcfg = void $ stack $ "build" : (opts ++ yaml mcfg)

-- | Build only dependencies
buildDeps :: Maybe FilePath -> GhcM ()
buildDeps = build ["--only-dependencies"]

data StackEnv = StackEnv {
	_stackRoot :: FilePath,
	_stackProject :: FilePath,
	_stackConfig :: FilePath,
	_stackGhc :: FilePath,
	_stackSnapshot :: FilePath,
	_stackLocal :: FilePath }

makeLenses ''StackEnv

getStackEnv :: PathsConf -> Maybe StackEnv
getStackEnv p = StackEnv <$>
	(p ^. pathOf "stack-root") <*>
	(p ^. pathOf "project-root") <*>
	(p ^. pathOf "config-location") <*>
	(p ^. pathOf "ghc-paths") <*>
	(p ^. pathOf "snapshot-pkg-db") <*>
	(p ^. pathOf "local-pkg-db")

-- | Projects paths
projectEnv :: FilePath -> GhcM StackEnv
projectEnv p = hsdevLiftIO $ Util.withCurrentDirectory p $ do
	paths' <- path Nothing
	maybe (hsdevError $ ToolError "stack" ("can't get paths for " ++ p)) return $ getStackEnv paths'

-- | Get package-db stack for stack environment
stackPackageDbStack :: Lens' StackEnv PackageDbStack
stackPackageDbStack = lens g s where
	g :: StackEnv -> PackageDbStack
	g env' = PackageDbStack $ map (PackageDb . P.fromFilePath) [_stackLocal env', _stackSnapshot env']
	s :: StackEnv -> PackageDbStack -> StackEnv
	s env' pdbs = env' {
		_stackSnapshot = fromMaybe (_stackSnapshot env') $ pdbs ^? packageDbStack . ix 1 . packageDb . P.path,
		_stackLocal = fromMaybe (_stackLocal env') $ pdbs ^? packageDbStack . ix 0 . packageDb . P.path }