{-# LANGUAGE LambdaCase #-}
module Utils.Stack (
    getStackYaml
  , getPackageConfig
  , getProgNameV
) where

import           Control.Arrow                ((&&&), (|||))
import           Data.Functor                 ((<&>))
import qualified Data.HashMap.Strict          as HM
import qualified Data.Text                    as T
import           Data.Yaml                    (Value, decodeFileThrow)
import           Hpack.Config                 (DecodeResult (..), Package (..),
                                               defaultDecodeOptions,
                                               readPackageConfig)
import           RIO.Process                  (mkDefaultProcessContext)
import           Stack.Config                 (getProjectConfig)
import           Stack.Prelude                (Abs, File, LogLevel (LevelInfo),
                                               MonadIO, Path,
                                               StylesUpdate (StylesUpdate),
                                               newMVar, runRIO, throwString,
                                               toFilePath)
import           Stack.Types.GlobalOpts       (GlobalOpts (..))
import           Stack.Types.LockFileBehavior (LockFileBehavior (LFBReadOnly))
import           Stack.Types.ProjectConfig    (ProjectConfig (PCProject))
import           Stack.Types.Runner           (Runner (..))
import           Stack.Types.StackYamlLoc     (StackYamlLoc (SYLDefault))

gops :: GlobalOpts
gops :: GlobalOpts
gops = GlobalOpts {
    $sel:reExecVersion:GlobalOpts :: Maybe String
reExecVersion = Maybe String
forall a. Maybe a
Nothing
  , $sel:dockerEntrypoint:GlobalOpts :: Maybe DockerEntrypoint
dockerEntrypoint = Maybe DockerEntrypoint
forall a. Maybe a
Nothing
  , $sel:logLevel:GlobalOpts :: LogLevel
logLevel = LogLevel
LevelInfo
  , $sel:timeInLog:GlobalOpts :: Bool
timeInLog = Bool
False
  , $sel:rslInLog:GlobalOpts :: Bool
rslInLog = Bool
False
  , $sel:planInLog:GlobalOpts :: Bool
planInLog = Bool
False
  , $sel:configMonoid:GlobalOpts :: ConfigMonoid
configMonoid = ConfigMonoid
forall a. Monoid a => a
mempty
  , $sel:snapshot:GlobalOpts :: Maybe AbstractSnapshot
snapshot = Maybe AbstractSnapshot
forall a. Maybe a
Nothing
  , $sel:compiler:GlobalOpts :: Maybe WantedCompiler
compiler = Maybe WantedCompiler
forall a. Maybe a
Nothing
  , $sel:terminal:GlobalOpts :: Bool
terminal = Bool
False
  , $sel:stylesUpdate:GlobalOpts :: StylesUpdate
stylesUpdate = [(Style, StyleSpec)] -> StylesUpdate
StylesUpdate []
  , $sel:termWidthOpt:GlobalOpts :: Maybe Int
termWidthOpt = Maybe Int
forall a. Maybe a
Nothing
  , $sel:stackYaml:GlobalOpts :: StackYamlLoc
stackYaml = StackYamlLoc
SYLDefault
  , $sel:lockFileBehavior:GlobalOpts :: LockFileBehavior
lockFileBehavior = LockFileBehavior
LFBReadOnly
  }

mkRunner :: MonadIO m => m Runner
mkRunner :: forall (m :: * -> *). MonadIO m => m Runner
mkRunner = GlobalOpts
-> Bool -> LogFunc -> Int -> ProcessContext -> MVar Bool -> Runner
Runner GlobalOpts
gops Bool
False LogFunc
forall a. Monoid a => a
mempty Int
0
    (ProcessContext -> MVar Bool -> Runner)
-> m ProcessContext -> m (MVar Bool -> Runner)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ProcessContext
forall (m :: * -> *). MonadIO m => m ProcessContext
mkDefaultProcessContext
    m (MVar Bool -> Runner) -> m (MVar Bool) -> m Runner
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> m (MVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Bool
False

getStackYamlPath :: IO (Path Abs File)
getStackYamlPath :: IO (Path Abs File)
getStackYamlPath = IO Runner
forall (m :: * -> *). MonadIO m => m Runner
mkRunner
    IO Runner
-> (Runner -> IO (ProjectConfig (Path Abs File)))
-> IO (ProjectConfig (Path Abs File))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Runner
 -> RIO Runner (ProjectConfig (Path Abs File))
 -> IO (ProjectConfig (Path Abs File)))
-> RIO Runner (ProjectConfig (Path Abs File))
-> Runner
-> IO (ProjectConfig (Path Abs File))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Runner
-> RIO Runner (ProjectConfig (Path Abs File))
-> IO (ProjectConfig (Path Abs File))
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (StackYamlLoc -> RIO Runner (ProjectConfig (Path Abs File))
forall env.
HasTerm env =>
StackYamlLoc -> RIO env (ProjectConfig (Path Abs File))
getProjectConfig StackYamlLoc
SYLDefault)
    IO (ProjectConfig (Path Abs File))
-> (ProjectConfig (Path Abs File) -> IO (Path Abs File))
-> IO (Path Abs File)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        PCProject Path Abs File
a -> Path Abs File -> IO (Path Abs File)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
a
        ProjectConfig (Path Abs File)
_           -> String -> IO (Path Abs File)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not find stack location"

getStackYaml :: IO (HM.HashMap T.Text Value)
getStackYaml :: IO (HashMap Text Value)
getStackYaml = IO (Path Abs File)
getStackYamlPath
    IO (Path Abs File)
-> (Path Abs File -> IO (HashMap Text Value))
-> IO (HashMap Text Value)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO (HashMap Text Value)
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
decodeFileThrow (String -> IO (HashMap Text Value))
-> (Path Abs File -> String)
-> Path Abs File
-> IO (HashMap Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
toFilePath

getPackageConfig :: IO DecodeResult
getPackageConfig :: IO DecodeResult
getPackageConfig = DecodeOptions -> IO (Either String DecodeResult)
readPackageConfig DecodeOptions
defaultDecodeOptions IO (Either String DecodeResult)
-> (Either String DecodeResult -> IO DecodeResult)
-> IO DecodeResult
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO DecodeResult
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> IO DecodeResult)
-> (DecodeResult -> IO DecodeResult)
-> Either String DecodeResult
-> IO DecodeResult
forall b d c. (b -> d) -> (c -> d) -> Either b c -> d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| DecodeResult -> IO DecodeResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

getProgNameV :: IO String
getProgNameV :: IO String
getProgNameV = IO DecodeResult
getPackageConfig
    IO DecodeResult -> (DecodeResult -> String) -> IO String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> String) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> String
forall a. Semigroup a => a -> a -> a
(<>) ((String, String) -> String)
-> (DecodeResult -> (String, String)) -> DecodeResult -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Package -> String
packageName (Package -> String)
-> (Package -> String) -> Package -> (String, String)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (Package -> String) -> Package -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> String
packageVersion)) (Package -> (String, String))
-> (DecodeResult -> Package) -> DecodeResult -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeResult -> Package
decodeResultPackage