{-# LANGUAGE TemplateHaskell, RankNTypes, PackageImports #-}

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" GHC
import qualified "ghc" 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 :: GhcM String
stackCompiler = do
	PackageDbStack -> [String] -> GhcM ()
tmpSession PackageDbStack
globalDb [String
"-no-user-package-db"]
	DynFlags
df <- MGhcT SessionConfig (First DynFlags) (LogT IO) DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
	let
		res :: [(String, Version)]
res =
			(PackageConfig -> (String, Version))
-> [PackageConfig] -> [(String, Version)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageConfig -> String
GHC.packageNameString (PackageConfig -> String)
-> (PackageConfig -> Version) -> PackageConfig -> (String, Version)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& PackageConfig -> Version
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Version
GHC.packageVersion) ([PackageConfig] -> [(String, Version)])
-> (DynFlags -> [PackageConfig]) -> DynFlags -> [(String, Version)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
			[PackageConfig] -> Maybe [PackageConfig] -> [PackageConfig]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [PackageConfig] -> [PackageConfig])
-> (DynFlags -> Maybe [PackageConfig])
-> DynFlags
-> [PackageConfig]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
			DynFlags -> Maybe [PackageConfig]
Compat.pkgDatabase (DynFlags -> [(String, Version)])
-> DynFlags -> [(String, Version)]
forall a b. (a -> b) -> a -> b
$ DynFlags
df
		compiler :: String
compiler = CompilerFlavor -> String
forall a. Pretty a => a -> String
T.display CompilerFlavor
buildCompilerFlavor
		CompilerId CompilerFlavor
_ Version
version' = CompilerId
buildCompilerId
		ver :: String
ver = String -> (Version -> String) -> Maybe Version -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Version -> String
forall a. Pretty a => a -> String
T.display Version
version') Version -> String
showVersion (Maybe Version -> String) -> Maybe Version -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, Version)] -> Maybe Version
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
compiler [(String, Version)]
res
	String -> GhcM String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GhcM String) -> String -> GhcM String
forall a b. (a -> b) -> a -> b
$ String
compiler String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ver

-- | Get arch for stack
stackArch :: String
stackArch :: String
stackArch = Arch -> String
forall a. Pretty a => a -> String
T.display Arch
buildArch

-- | Invoke stack command, we are trying to get actual stack near current hsdev executable
stack :: [String] -> GhcM String
stack :: [String] -> GhcM String
stack [String]
cmd' = GhcM String -> GhcM String
forall (m :: * -> *) a. MonadCatch m => m a -> m a
hsdevLiftIO (GhcM String -> GhcM String) -> GhcM String -> GhcM String
forall a b. (a -> b) -> a -> b
$ do
	String
curExe <- IO String -> GhcM String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getExecutablePath
	String
stackExe <- String -> GhcM String -> GhcM String
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> m a -> m a
Util.withCurrentDirectory (String -> String
takeDirectory String
curExe) (GhcM String -> GhcM String) -> GhcM String -> GhcM String
forall a b. (a -> b) -> a -> b
$
		IO (Maybe String)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
findExecutable String
"stack") MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe String)
-> (Maybe String -> GhcM String) -> GhcM String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GhcM String
-> (String -> GhcM String) -> Maybe String -> GhcM String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HsDevError -> GhcM String
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> GhcM String) -> HsDevError -> GhcM String
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
ToolNotFound String
"stack") String -> GhcM String
forall (m :: * -> *) a. Monad m => a -> m a
return
	String
comp <- GhcM String
stackCompiler
	let
		args' :: [String]
args' = [String
"--compiler", String
comp, String
"--arch", String
stackArch] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
cmd'
	Level -> Text -> GhcM ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> GhcM ()) -> Text -> GhcM ()
forall a b. (a -> b) -> a -> b
$ String -> [FormatArg] -> Text
forall r. FormatResult r => String -> [FormatArg] -> r
formats String
"invoking stack: {exe} {args}" [
		String
"exe" String -> String -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% String
stackExe,
		String
"args" String -> String -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% [String] -> String
unwords [String]
args']
	IO String -> GhcM String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> GhcM String) -> IO String -> GhcM String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO String
runTool_ String
stackExe [String]
args'

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

type PathsConf = Map String FilePath

-- | Stack path
path :: Maybe FilePath -> GhcM PathsConf
path :: Maybe String -> GhcM PathsConf
path Maybe String
mcfg = (String -> PathsConf) -> GhcM String -> GhcM PathsConf
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([(String, String)] -> PathsConf
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, String)] -> PathsConf)
-> (String -> [(String, String)]) -> String -> PathsConf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (String, String)
breakPath ([String] -> [(String, String)])
-> (String -> [String]) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) (GhcM String -> GhcM PathsConf) -> GhcM String -> GhcM PathsConf
forall a b. (a -> b) -> a -> b
$ [String] -> GhcM String
stack (String
"path" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Maybe String -> [String]
yaml Maybe String
mcfg) where
	breakPath :: String -> (String, FilePath)
	breakPath :: String -> (String, String)
breakPath = (String -> String) -> (String, String) -> (String, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1) ((String, String) -> (String, String))
-> (String -> (String, String)) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')

-- | Get path for
pathOf :: String -> Lens' PathsConf (Maybe FilePath)
pathOf :: String -> Lens' PathsConf (Maybe String)
pathOf = String
-> (Maybe String -> f (Maybe String)) -> PathsConf -> f PathsConf
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at

-- | Build stack project
build :: [String] -> Maybe FilePath -> GhcM ()
build :: [String] -> Maybe String -> GhcM ()
build [String]
opts Maybe String
mcfg = GhcM String -> GhcM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (GhcM String -> GhcM ()) -> GhcM String -> GhcM ()
forall a b. (a -> b) -> a -> b
$ [String] -> GhcM String
stack ([String] -> GhcM String) -> [String] -> GhcM String
forall a b. (a -> b) -> a -> b
$ String
"build" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ([String]
opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Maybe String -> [String]
yaml Maybe String
mcfg)

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

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

makeLenses ''StackEnv

getStackEnv :: PathsConf -> Maybe StackEnv
getStackEnv :: PathsConf -> Maybe StackEnv
getStackEnv PathsConf
p = String
-> String -> String -> String -> String -> String -> StackEnv
StackEnv (String
 -> String -> String -> String -> String -> String -> StackEnv)
-> Maybe String
-> Maybe
     (String -> String -> String -> String -> String -> StackEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
	(PathsConf
p PathsConf
-> Getting (Maybe String) PathsConf (Maybe String) -> Maybe String
forall s a. s -> Getting a s a -> a
^. String -> Lens' PathsConf (Maybe String)
pathOf String
"stack-root") Maybe (String -> String -> String -> String -> String -> StackEnv)
-> Maybe String
-> Maybe (String -> String -> String -> String -> StackEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
	(PathsConf
p PathsConf
-> Getting (Maybe String) PathsConf (Maybe String) -> Maybe String
forall s a. s -> Getting a s a -> a
^. String -> Lens' PathsConf (Maybe String)
pathOf String
"project-root") Maybe (String -> String -> String -> String -> StackEnv)
-> Maybe String -> Maybe (String -> String -> String -> StackEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
	(PathsConf
p PathsConf
-> Getting (Maybe String) PathsConf (Maybe String) -> Maybe String
forall s a. s -> Getting a s a -> a
^. String -> Lens' PathsConf (Maybe String)
pathOf String
"config-location") Maybe (String -> String -> String -> StackEnv)
-> Maybe String -> Maybe (String -> String -> StackEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
	(PathsConf
p PathsConf
-> Getting (Maybe String) PathsConf (Maybe String) -> Maybe String
forall s a. s -> Getting a s a -> a
^. String -> Lens' PathsConf (Maybe String)
pathOf String
"ghc-paths") Maybe (String -> String -> StackEnv)
-> Maybe String -> Maybe (String -> StackEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
	(PathsConf
p PathsConf
-> Getting (Maybe String) PathsConf (Maybe String) -> Maybe String
forall s a. s -> Getting a s a -> a
^. String -> Lens' PathsConf (Maybe String)
pathOf String
"snapshot-pkg-db") Maybe (String -> StackEnv) -> Maybe String -> Maybe StackEnv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
	(PathsConf
p PathsConf
-> Getting (Maybe String) PathsConf (Maybe String) -> Maybe String
forall s a. s -> Getting a s a -> a
^. String -> Lens' PathsConf (Maybe String)
pathOf String
"local-pkg-db")

-- | Projects paths
projectEnv :: FilePath -> GhcM StackEnv
projectEnv :: String -> GhcM StackEnv
projectEnv String
p = GhcM StackEnv -> GhcM StackEnv
forall (m :: * -> *) a. MonadCatch m => m a -> m a
hsdevLiftIO (GhcM StackEnv -> GhcM StackEnv) -> GhcM StackEnv -> GhcM StackEnv
forall a b. (a -> b) -> a -> b
$ String -> GhcM StackEnv -> GhcM StackEnv
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> m a -> m a
Util.withCurrentDirectory String
p (GhcM StackEnv -> GhcM StackEnv) -> GhcM StackEnv -> GhcM StackEnv
forall a b. (a -> b) -> a -> b
$ do
	PathsConf
paths' <- Maybe String -> GhcM PathsConf
path Maybe String
forall a. Maybe a
Nothing
	GhcM StackEnv
-> (StackEnv -> GhcM StackEnv) -> Maybe StackEnv -> GhcM StackEnv
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HsDevError -> GhcM StackEnv
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> GhcM StackEnv) -> HsDevError -> GhcM StackEnv
forall a b. (a -> b) -> a -> b
$ String -> String -> HsDevError
ToolError String
"stack" (String
"can't get paths for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p)) StackEnv -> GhcM StackEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StackEnv -> GhcM StackEnv)
-> Maybe StackEnv -> GhcM StackEnv
forall a b. (a -> b) -> a -> b
$ PathsConf -> Maybe StackEnv
getStackEnv PathsConf
paths'

-- | Get package-db stack for stack environment
stackPackageDbStack :: Lens' StackEnv PackageDbStack
stackPackageDbStack :: (PackageDbStack -> f PackageDbStack) -> StackEnv -> f StackEnv
stackPackageDbStack = (StackEnv -> PackageDbStack)
-> (StackEnv -> PackageDbStack -> StackEnv)
-> Lens StackEnv StackEnv PackageDbStack PackageDbStack
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens StackEnv -> PackageDbStack
g StackEnv -> PackageDbStack -> StackEnv
s where
	g :: StackEnv -> PackageDbStack
	g :: StackEnv -> PackageDbStack
g StackEnv
env' = [PackageDb] -> PackageDbStack
PackageDbStack ([PackageDb] -> PackageDbStack) -> [PackageDb] -> PackageDbStack
forall a b. (a -> b) -> a -> b
$ (String -> PackageDb) -> [String] -> [PackageDb]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> PackageDb
PackageDb (Text -> PackageDb) -> (String -> Text) -> String -> PackageDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
P.fromFilePath) [StackEnv -> String
_stackLocal StackEnv
env', StackEnv -> String
_stackSnapshot StackEnv
env']
	s :: StackEnv -> PackageDbStack -> StackEnv
	s :: StackEnv -> PackageDbStack -> StackEnv
s StackEnv
env' PackageDbStack
pdbs = StackEnv
env' {
		_stackSnapshot :: String
_stackSnapshot = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (StackEnv -> String
_stackSnapshot StackEnv
env') (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ PackageDbStack
pdbs PackageDbStack
-> Getting (First String) PackageDbStack String -> Maybe String
forall s a. s -> Getting (First a) s a -> Maybe a
^? ([PackageDb] -> Const (First String) [PackageDb])
-> PackageDbStack -> Const (First String) PackageDbStack
Iso' PackageDbStack [PackageDb]
packageDbStack (([PackageDb] -> Const (First String) [PackageDb])
 -> PackageDbStack -> Const (First String) PackageDbStack)
-> ((String -> Const (First String) String)
    -> [PackageDb] -> Const (First String) [PackageDb])
-> Getting (First String) PackageDbStack String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index [PackageDb] -> Traversal' [PackageDb] (IxValue [PackageDb])
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index [PackageDb]
1 ((PackageDb -> Const (First String) PackageDb)
 -> [PackageDb] -> Const (First String) [PackageDb])
-> ((String -> Const (First String) String)
    -> PackageDb -> Const (First String) PackageDb)
-> (String -> Const (First String) String)
-> [PackageDb]
-> Const (First String) [PackageDb]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First String) Text)
-> PackageDb -> Const (First String) PackageDb
Traversal' PackageDb Text
packageDb ((Text -> Const (First String) Text)
 -> PackageDb -> Const (First String) PackageDb)
-> ((String -> Const (First String) String)
    -> Text -> Const (First String) Text)
-> (String -> Const (First String) String)
-> PackageDb
-> Const (First String) PackageDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Const (First String) String)
-> Text -> Const (First String) Text
Lens' Text String
P.path,
		_stackLocal :: String
_stackLocal = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (StackEnv -> String
_stackLocal StackEnv
env') (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ PackageDbStack
pdbs PackageDbStack
-> Getting (First String) PackageDbStack String -> Maybe String
forall s a. s -> Getting (First a) s a -> Maybe a
^? ([PackageDb] -> Const (First String) [PackageDb])
-> PackageDbStack -> Const (First String) PackageDbStack
Iso' PackageDbStack [PackageDb]
packageDbStack (([PackageDb] -> Const (First String) [PackageDb])
 -> PackageDbStack -> Const (First String) PackageDbStack)
-> ((String -> Const (First String) String)
    -> [PackageDb] -> Const (First String) [PackageDb])
-> Getting (First String) PackageDbStack String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index [PackageDb] -> Traversal' [PackageDb] (IxValue [PackageDb])
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index [PackageDb]
0 ((PackageDb -> Const (First String) PackageDb)
 -> [PackageDb] -> Const (First String) [PackageDb])
-> ((String -> Const (First String) String)
    -> PackageDb -> Const (First String) PackageDb)
-> (String -> Const (First String) String)
-> [PackageDb]
-> Const (First String) [PackageDb]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First String) Text)
-> PackageDb -> Const (First String) PackageDb
Traversal' PackageDb Text
packageDb ((Text -> Const (First String) Text)
 -> PackageDb -> Const (First String) PackageDb)
-> ((String -> Const (First String) String)
    -> Text -> Const (First String) Text)
-> (String -> Const (First String) String)
-> PackageDb
-> Const (First String) PackageDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Const (First String) String)
-> Text -> Const (First String) Text
Lens' Text String
P.path }