-- |
-- Module: Staversion.Internal.StackConfig
-- Description: Central entity that deals with stack.yaml
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- __This is an internal module. End-users should not use it.__
module Staversion.Internal.StackConfig
       ( -- * StackConfig
         StackConfig,
         newStackConfig,
         scCommand,
         readResolver,
         readProjectCabals,
         -- * For tests
         configLocationFromText
       ) where

import Control.Applicative (empty, many, some, (<$>), (<*>))
import Control.Monad (void, when)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isSpace)
import Data.List (isSuffixOf)
import Data.Monoid ((<>))
import Data.Yaml (FromJSON(..), Value(..), (.:), decodeEither')
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.ByteString as BS
import System.Directory (getDirectoryContents)
import System.Exit (ExitCode(ExitFailure))
import System.FilePath ((</>), takeDirectory)
import System.Process
  ( shell, readCreateProcessWithExitCode
  )

import Staversion.Internal.EIO (EIO, toEIO, runEIO, eitherToEIO, toEIOShow)
import Staversion.Internal.Log (Logger, logWarn, logDebug)
import Staversion.Internal.Query (Resolver, ErrorMsg)
import Staversion.Internal.Megaparsec (Parser, runParser, satisfy, space)


-- | Central entity that deals with stack.yaml and @stack@ command.
data StackConfig =
  StackConfig
  { StackConfig -> ErrorMsg
scCommand :: String,
    -- ^ (accessor) shell command for @stack@ tool.
    StackConfig -> Logger
scLogger :: Logger
  }

newStackConfig :: Logger -> StackConfig
newStackConfig :: Logger -> StackConfig
newStackConfig = ErrorMsg -> Logger -> StackConfig
StackConfig ErrorMsg
"stack"

-- | Element of @packages@ field. If the path is for the main project
-- (i.e. @extra-dep@ is false), it's 'Just'. Otherwise, it's
-- 'Nothing'.
newtype ProjectPath = ProjectPath (Maybe FilePath)
                      deriving (Int -> ProjectPath -> ShowS
[ProjectPath] -> ShowS
ProjectPath -> ErrorMsg
(Int -> ProjectPath -> ShowS)
-> (ProjectPath -> ErrorMsg)
-> ([ProjectPath] -> ShowS)
-> Show ProjectPath
forall a.
(Int -> a -> ShowS) -> (a -> ErrorMsg) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProjectPath -> ShowS
showsPrec :: Int -> ProjectPath -> ShowS
$cshow :: ProjectPath -> ErrorMsg
show :: ProjectPath -> ErrorMsg
$cshowList :: [ProjectPath] -> ShowS
showList :: [ProjectPath] -> ShowS
Show,ProjectPath -> ProjectPath -> Bool
(ProjectPath -> ProjectPath -> Bool)
-> (ProjectPath -> ProjectPath -> Bool) -> Eq ProjectPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProjectPath -> ProjectPath -> Bool
== :: ProjectPath -> ProjectPath -> Bool
$c/= :: ProjectPath -> ProjectPath -> Bool
/= :: ProjectPath -> ProjectPath -> Bool
Eq,Eq ProjectPath
Eq ProjectPath =>
(ProjectPath -> ProjectPath -> Ordering)
-> (ProjectPath -> ProjectPath -> Bool)
-> (ProjectPath -> ProjectPath -> Bool)
-> (ProjectPath -> ProjectPath -> Bool)
-> (ProjectPath -> ProjectPath -> Bool)
-> (ProjectPath -> ProjectPath -> ProjectPath)
-> (ProjectPath -> ProjectPath -> ProjectPath)
-> Ord ProjectPath
ProjectPath -> ProjectPath -> Bool
ProjectPath -> ProjectPath -> Ordering
ProjectPath -> ProjectPath -> ProjectPath
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ProjectPath -> ProjectPath -> Ordering
compare :: ProjectPath -> ProjectPath -> Ordering
$c< :: ProjectPath -> ProjectPath -> Bool
< :: ProjectPath -> ProjectPath -> Bool
$c<= :: ProjectPath -> ProjectPath -> Bool
<= :: ProjectPath -> ProjectPath -> Bool
$c> :: ProjectPath -> ProjectPath -> Bool
> :: ProjectPath -> ProjectPath -> Bool
$c>= :: ProjectPath -> ProjectPath -> Bool
>= :: ProjectPath -> ProjectPath -> Bool
$cmax :: ProjectPath -> ProjectPath -> ProjectPath
max :: ProjectPath -> ProjectPath -> ProjectPath
$cmin :: ProjectPath -> ProjectPath -> ProjectPath
min :: ProjectPath -> ProjectPath -> ProjectPath
Ord)

instance FromJSON ProjectPath where
  parseJSON :: Value -> Parser ProjectPath
parseJSON (String Text
s) = ProjectPath -> Parser ProjectPath
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectPath -> Parser ProjectPath)
-> ProjectPath -> Parser ProjectPath
forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> ProjectPath
ProjectPath (Maybe ErrorMsg -> ProjectPath) -> Maybe ErrorMsg -> ProjectPath
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Maybe ErrorMsg
forall a. a -> Maybe a
Just (ErrorMsg -> Maybe ErrorMsg) -> ErrorMsg -> Maybe ErrorMsg
forall a b. (a -> b) -> a -> b
$ Text -> ErrorMsg
T.unpack Text
s
  parseJSON (Object Object
_) = ProjectPath -> Parser ProjectPath
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectPath -> Parser ProjectPath)
-> ProjectPath -> Parser ProjectPath
forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> ProjectPath
ProjectPath (Maybe ErrorMsg -> ProjectPath) -> Maybe ErrorMsg -> ProjectPath
forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg
forall a. Maybe a
Nothing
  parseJSON Value
_ = Parser ProjectPath
forall a. Parser a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | @stack.yaml@ content
data StackYaml =
  StackYaml
  { StackYaml -> ErrorMsg
stackYamlPath :: FilePath,
    StackYaml -> ErrorMsg
stackYamlResolver :: Resolver,
    StackYaml -> [ProjectPath]
stackYamlPackages :: [ProjectPath]
  }
  deriving (Int -> StackYaml -> ShowS
[StackYaml] -> ShowS
StackYaml -> ErrorMsg
(Int -> StackYaml -> ShowS)
-> (StackYaml -> ErrorMsg)
-> ([StackYaml] -> ShowS)
-> Show StackYaml
forall a.
(Int -> a -> ShowS) -> (a -> ErrorMsg) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StackYaml -> ShowS
showsPrec :: Int -> StackYaml -> ShowS
$cshow :: StackYaml -> ErrorMsg
show :: StackYaml -> ErrorMsg
$cshowList :: [StackYaml] -> ShowS
showList :: [StackYaml] -> ShowS
Show,StackYaml -> StackYaml -> Bool
(StackYaml -> StackYaml -> Bool)
-> (StackYaml -> StackYaml -> Bool) -> Eq StackYaml
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StackYaml -> StackYaml -> Bool
== :: StackYaml -> StackYaml -> Bool
$c/= :: StackYaml -> StackYaml -> Bool
/= :: StackYaml -> StackYaml -> Bool
Eq,Eq StackYaml
Eq StackYaml =>
(StackYaml -> StackYaml -> Ordering)
-> (StackYaml -> StackYaml -> Bool)
-> (StackYaml -> StackYaml -> Bool)
-> (StackYaml -> StackYaml -> Bool)
-> (StackYaml -> StackYaml -> Bool)
-> (StackYaml -> StackYaml -> StackYaml)
-> (StackYaml -> StackYaml -> StackYaml)
-> Ord StackYaml
StackYaml -> StackYaml -> Bool
StackYaml -> StackYaml -> Ordering
StackYaml -> StackYaml -> StackYaml
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StackYaml -> StackYaml -> Ordering
compare :: StackYaml -> StackYaml -> Ordering
$c< :: StackYaml -> StackYaml -> Bool
< :: StackYaml -> StackYaml -> Bool
$c<= :: StackYaml -> StackYaml -> Bool
<= :: StackYaml -> StackYaml -> Bool
$c> :: StackYaml -> StackYaml -> Bool
> :: StackYaml -> StackYaml -> Bool
$c>= :: StackYaml -> StackYaml -> Bool
>= :: StackYaml -> StackYaml -> Bool
$cmax :: StackYaml -> StackYaml -> StackYaml
max :: StackYaml -> StackYaml -> StackYaml
$cmin :: StackYaml -> StackYaml -> StackYaml
min :: StackYaml -> StackYaml -> StackYaml
Ord)

instance FromJSON StackYaml where
  parseJSON :: Value -> Parser StackYaml
parseJSON (Object Object
o) = ErrorMsg -> ErrorMsg -> [ProjectPath] -> StackYaml
StackYaml ErrorMsg
"" (ErrorMsg -> [ProjectPath] -> StackYaml)
-> Parser ErrorMsg -> Parser ([ProjectPath] -> StackYaml)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser ErrorMsg
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"resolver") Parser ([ProjectPath] -> StackYaml)
-> Parser [ProjectPath] -> Parser StackYaml
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o Object -> Key -> Parser [ProjectPath]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"packages")
  parseJSON Value
_ = Parser StackYaml
forall a. Parser a
forall (f :: * -> *) a. Alternative f => f a
empty

readStackYaml :: FilePath -> EIO StackYaml
readStackYaml :: ErrorMsg -> EIO StackYaml
readStackYaml ErrorMsg
file = IO (Either ParseException StackYaml) -> EIO StackYaml
forall e a. Show e => IO (Either e a) -> EIO a
toEIOShow (IO (Either ParseException StackYaml) -> EIO StackYaml)
-> IO (Either ParseException StackYaml) -> EIO StackYaml
forall a b. (a -> b) -> a -> b
$ (ByteString -> Either ParseException StackYaml)
-> IO ByteString -> IO (Either ParseException StackYaml)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((StackYaml -> StackYaml)
-> Either ParseException StackYaml
-> Either ParseException StackYaml
forall a b.
(a -> b) -> Either ParseException a -> Either ParseException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StackYaml -> StackYaml
setPath (Either ParseException StackYaml
 -> Either ParseException StackYaml)
-> (ByteString -> Either ParseException StackYaml)
-> ByteString
-> Either ParseException StackYaml
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseException StackYaml
forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither') (IO ByteString -> IO (Either ParseException StackYaml))
-> IO ByteString -> IO (Either ParseException StackYaml)
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> IO ByteString
BS.readFile ErrorMsg
file
  where
    setPath :: StackYaml -> StackYaml
setPath StackYaml
sy = StackYaml
sy { stackYamlPath = file }

findProjectCabal :: Logger -> FilePath -> ProjectPath -> IO [FilePath]
findProjectCabal :: Logger -> ErrorMsg -> ProjectPath -> IO [ErrorMsg]
findProjectCabal Logger
_ ErrorMsg
_ (ProjectPath Maybe ErrorMsg
Nothing) = [ErrorMsg] -> IO [ErrorMsg]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
findProjectCabal Logger
logger ErrorMsg
base_path (ProjectPath (Just ErrorMsg
project_path)) = do
  [ErrorMsg]
all_files <- ErrorMsg -> IO [ErrorMsg]
getDirectoryContents ErrorMsg
project_fullpath
  let result_files :: [ErrorMsg]
result_files = ShowS -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (\ErrorMsg
f -> ErrorMsg
project_fullpath ErrorMsg -> ShowS
</> ErrorMsg
f) ([ErrorMsg] -> [ErrorMsg]) -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ (ErrorMsg -> Bool) -> [ErrorMsg] -> [ErrorMsg]
forall a. (a -> Bool) -> [a] -> [a]
filter ErrorMsg -> Bool
isCabalFile [ErrorMsg]
all_files
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ErrorMsg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ErrorMsg]
result_files Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Logger -> ErrorMsg -> IO ()
logWarn Logger
logger (ErrorMsg
"No .cabal file is found in " ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
project_fullpath)
  [ErrorMsg] -> IO [ErrorMsg]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrorMsg]
result_files
  where
    project_fullpath :: ErrorMsg
project_fullpath = ErrorMsg
base_path ErrorMsg -> ShowS
</> ErrorMsg
project_path
    isCabalFile :: FilePath -> Bool
    isCabalFile :: ErrorMsg -> Bool
isCabalFile ErrorMsg
f = ErrorMsg
".cabal" ErrorMsg -> ErrorMsg -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` ErrorMsg
f

findProjectCabals :: Logger
                  -> StackYaml
                  -> IO [FilePath] -- ^ paths to all project .cabal files.
findProjectCabals :: Logger -> StackYaml -> IO [ErrorMsg]
findProjectCabals Logger
logger StackYaml
stack_yaml = do
  [ErrorMsg]
cabals <- ([[ErrorMsg]] -> [ErrorMsg]) -> IO [[ErrorMsg]] -> IO [ErrorMsg]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ErrorMsg]] -> [ErrorMsg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[ErrorMsg]] -> IO [ErrorMsg])
-> IO [[ErrorMsg]] -> IO [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ (ProjectPath -> IO [ErrorMsg]) -> [ProjectPath] -> IO [[ErrorMsg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Logger -> ErrorMsg -> ProjectPath -> IO [ErrorMsg]
findProjectCabal Logger
logger ErrorMsg
base_path) [ProjectPath]
packages
  [ErrorMsg] -> IO ()
forall {a}. [a] -> IO ()
warnEmpty [ErrorMsg]
cabals
  [ErrorMsg] -> IO [ErrorMsg]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrorMsg]
cabals
  where
    stack_yaml_path :: ErrorMsg
stack_yaml_path = StackYaml -> ErrorMsg
stackYamlPath StackYaml
stack_yaml
    base_path :: ErrorMsg
base_path = ShowS
takeDirectory ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ErrorMsg
stack_yaml_path
    packages :: [ProjectPath]
packages = StackYaml -> [ProjectPath]
stackYamlPackages StackYaml
stack_yaml
    warnEmpty :: [a] -> IO ()
warnEmpty [] = Logger -> ErrorMsg -> IO ()
logWarn Logger
logger (ErrorMsg
"No project .cabal files found in " ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
stack_yaml_path)
    warnEmpty [a]
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

readProjectCabals :: StackConfig
                  -> Maybe FilePath
                  -- ^ path to stack.yaml. If 'Nothing', the default stack.yaml is used.
                  -> IO (Either ErrorMsg [FilePath])
                  -- ^ paths to all .cabal files of the stack projects.
readProjectCabals :: StackConfig -> Maybe ErrorMsg -> IO (Either ErrorMsg [ErrorMsg])
readProjectCabals StackConfig
s Maybe ErrorMsg
f = EIO [ErrorMsg] -> IO (Either ErrorMsg [ErrorMsg])
forall a. EIO a -> IO (Either ErrorMsg a)
runEIO (EIO [ErrorMsg] -> IO (Either ErrorMsg [ErrorMsg]))
-> EIO [ErrorMsg] -> IO (Either ErrorMsg [ErrorMsg])
forall a b. (a -> b) -> a -> b
$ StackConfig -> Maybe ErrorMsg -> EIO [ErrorMsg]
readProjectCabalsEIO StackConfig
s Maybe ErrorMsg
f

readProjectCabalsEIO :: StackConfig -> Maybe FilePath -> EIO [FilePath]
readProjectCabalsEIO :: StackConfig -> Maybe ErrorMsg -> EIO [ErrorMsg]
readProjectCabalsEIO StackConfig
sconf (Just ErrorMsg
stack_yaml_file) = do
  StackYaml
stack_yaml <- ErrorMsg -> EIO StackYaml
readStackYaml ErrorMsg
stack_yaml_file
  IO [ErrorMsg] -> EIO [ErrorMsg]
forall a. IO a -> ExceptT ErrorMsg IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ErrorMsg] -> EIO [ErrorMsg])
-> IO [ErrorMsg] -> EIO [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ Logger -> StackYaml -> IO [ErrorMsg]
findProjectCabals Logger
logger StackYaml
stack_yaml
  where
    logger :: Logger
logger = StackConfig -> Logger
scLogger StackConfig
sconf
readProjectCabalsEIO StackConfig
sconf Maybe ErrorMsg
Nothing = do
  ErrorMsg
stack_yaml_file <- StackConfig -> EIO ErrorMsg
configLocation StackConfig
sconf
  StackConfig -> Maybe ErrorMsg -> EIO [ErrorMsg]
readProjectCabalsEIO StackConfig
sconf (Maybe ErrorMsg -> EIO [ErrorMsg])
-> Maybe ErrorMsg -> EIO [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Maybe ErrorMsg
forall a. a -> Maybe a
Just ErrorMsg
stack_yaml_file

-- | Read the @resolver@ field in stack.yaml.
readResolver :: StackConfig
             -> Maybe FilePath
             -- ^ path to stack.yaml. If 'Nothing', the default stack.yaml is used.
             -> IO (Either ErrorMsg Resolver)
readResolver :: StackConfig -> Maybe ErrorMsg -> IO (Either ErrorMsg ErrorMsg)
readResolver StackConfig
sconf Maybe ErrorMsg
mfile = EIO ErrorMsg -> IO (Either ErrorMsg ErrorMsg)
forall a. EIO a -> IO (Either ErrorMsg a)
runEIO (EIO ErrorMsg -> IO (Either ErrorMsg ErrorMsg))
-> EIO ErrorMsg -> IO (Either ErrorMsg ErrorMsg)
forall a b. (a -> b) -> a -> b
$ case Maybe ErrorMsg
mfile of
  Just ErrorMsg
file -> ErrorMsg -> EIO ErrorMsg
doRead ErrorMsg
file
  Maybe ErrorMsg
Nothing -> ErrorMsg -> EIO ErrorMsg
doRead (ErrorMsg -> EIO ErrorMsg) -> EIO ErrorMsg -> EIO ErrorMsg
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StackConfig -> EIO ErrorMsg
configLocation StackConfig
sconf
  where
    doRead :: ErrorMsg -> EIO ErrorMsg
doRead ErrorMsg
file = (StackYaml -> ErrorMsg) -> EIO StackYaml -> EIO ErrorMsg
forall a b.
(a -> b) -> ExceptT ErrorMsg IO a -> ExceptT ErrorMsg IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StackYaml -> ErrorMsg
stackYamlResolver (EIO StackYaml -> EIO ErrorMsg) -> EIO StackYaml -> EIO ErrorMsg
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> EIO StackYaml
readStackYaml ErrorMsg
file

-- | Get the path to stack.yaml that @stack@ uses as the current
-- config.
configLocation :: StackConfig -> EIO FilePath
configLocation :: StackConfig -> EIO ErrorMsg
configLocation StackConfig
sconfig = do
  Text
pout <- StackConfig -> EIO Text
getProcessOutput StackConfig
sconfig
  ErrorMsg
path <- Either ErrorMsg ErrorMsg -> EIO ErrorMsg
forall a. Either ErrorMsg a -> EIO a
eitherToEIO (Either ErrorMsg ErrorMsg -> EIO ErrorMsg)
-> Either ErrorMsg ErrorMsg -> EIO ErrorMsg
forall a b. (a -> b) -> a -> b
$ Text -> Either ErrorMsg ErrorMsg
configLocationFromText Text
pout
  IO () -> ExceptT ErrorMsg IO ()
forall a. IO a -> ExceptT ErrorMsg IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ErrorMsg IO ())
-> IO () -> ExceptT ErrorMsg IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> ErrorMsg -> IO ()
logDebug Logger
logger (ErrorMsg
"Project stack config: " ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
path)
  ErrorMsg -> EIO ErrorMsg
forall a. a -> ExceptT ErrorMsg IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ErrorMsg
path
  where
    logger :: Logger
logger = StackConfig -> Logger
scLogger StackConfig
sconfig

getProcessOutput :: StackConfig -> EIO Text
getProcessOutput :: StackConfig -> EIO Text
getProcessOutput StackConfig
sconfig = IO (Either ErrorMsg Text) -> EIO Text
forall a. IO (Either ErrorMsg a) -> EIO a
toEIO (IO (Either ErrorMsg Text) -> EIO Text)
-> IO (Either ErrorMsg Text) -> EIO Text
forall a b. (a -> b) -> a -> b
$ (ExitCode, ErrorMsg, ErrorMsg) -> IO (Either ErrorMsg Text)
handleResult ((ExitCode, ErrorMsg, ErrorMsg) -> IO (Either ErrorMsg Text))
-> IO (ExitCode, ErrorMsg, ErrorMsg) -> IO (Either ErrorMsg Text)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CreateProcess -> ErrorMsg -> IO (ExitCode, ErrorMsg, ErrorMsg)
readCreateProcessWithExitCode CreateProcess
cmd ErrorMsg
""
  where
    logger :: Logger
logger = StackConfig -> Logger
scLogger StackConfig
sconfig
    command :: ErrorMsg
command = StackConfig -> ErrorMsg
scCommand StackConfig
sconfig
    cmd_str :: ErrorMsg
cmd_str = ErrorMsg
command ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
" path"
    cmd :: CreateProcess
cmd = ErrorMsg -> CreateProcess
shell ErrorMsg
cmd_str
    warnErr :: ErrorMsg -> IO ()
warnErr ErrorMsg
err = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ErrorMsg -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ErrorMsg
err Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> ErrorMsg -> IO ()
logWarn Logger
logger ErrorMsg
err
    handleResult :: (ExitCode, ErrorMsg, ErrorMsg) -> IO (Either ErrorMsg Text)
handleResult (ExitCode
code, ErrorMsg
out, ErrorMsg
err) = do
      case ExitCode
code of
       ExitFailure Int
c -> do
         let code_err :: ErrorMsg
code_err = ErrorMsg
"'" ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
cmd_str ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
"' returns non-zero exit code: " ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Int
c ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
"."
             hint :: ErrorMsg
hint = ErrorMsg
"It requires the 'stack' tool. Maybe you have to specify the command by --stack-command option."
         Logger -> ErrorMsg -> IO ()
logWarn Logger
logger ErrorMsg
code_err
         ErrorMsg -> IO ()
warnErr ErrorMsg
err
         Either ErrorMsg Text -> IO (Either ErrorMsg Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMsg Text -> IO (Either ErrorMsg Text))
-> Either ErrorMsg Text -> IO (Either ErrorMsg Text)
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Either ErrorMsg Text
forall a b. a -> Either a b
Left (ErrorMsg
code_err ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
"\n" ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
hint)
       ExitCode
_ -> do
         ErrorMsg -> IO ()
warnErr ErrorMsg
err
         Either ErrorMsg Text -> IO (Either ErrorMsg Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMsg Text -> IO (Either ErrorMsg Text))
-> Either ErrorMsg Text -> IO (Either ErrorMsg Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either ErrorMsg Text
forall a b. b -> Either a b
Right (Text -> Either ErrorMsg Text) -> Text -> Either ErrorMsg Text
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Text
pack ErrorMsg
out

configLocationFromText :: Text -> Either ErrorMsg FilePath
configLocationFromText :: Text -> Either ErrorMsg ErrorMsg
configLocationFromText Text
input = [ErrorMsg] -> Either ErrorMsg ErrorMsg
toEither ([ErrorMsg] -> Either ErrorMsg ErrorMsg)
-> [ErrorMsg] -> Either ErrorMsg ErrorMsg
forall a b. (a -> b) -> a -> b
$ Text -> [ErrorMsg]
findField (Text -> [ErrorMsg]) -> [Text] -> [ErrorMsg]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [Text]
T.lines Text
input
  where
    fieldName :: Text
fieldName = Text
"config-location"
    findField :: Text -> [FilePath]
    findField :: Text -> [ErrorMsg]
findField Text
line = do
      (Text
fname, Text
fvalue) <- [(Text, Text)]
-> ((Text, Text) -> [(Text, Text)])
-> Maybe (Text, Text)
-> [(Text, Text)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Text, Text) -> [(Text, Text)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, Text) -> [(Text, Text)])
-> Maybe (Text, Text) -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Text, Text)
parseField Text
line
      if Text
fname Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
fieldName
        then ErrorMsg -> [ErrorMsg]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorMsg -> [ErrorMsg]) -> ErrorMsg -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ Text -> ErrorMsg
T.unpack Text
fvalue
        else []
    toEither :: [FilePath] -> Either ErrorMsg FilePath
    toEither :: [ErrorMsg] -> Either ErrorMsg ErrorMsg
toEither [] = ErrorMsg -> Either ErrorMsg ErrorMsg
forall a b. a -> Either a b
Left (ErrorMsg
"Cannot find '" ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> ErrorMsg
T.unpack Text
fieldName ErrorMsg -> ShowS
forall a. Semigroup a => a -> a -> a
<> ErrorMsg
"' field in stack path")
    toEither (ErrorMsg
r:[ErrorMsg]
_) = ErrorMsg -> Either ErrorMsg ErrorMsg
forall a b. b -> Either a b
Right ErrorMsg
r
    parseField :: Text -> Maybe (Text, Text)
    parseField :: Text -> Maybe (Text, Text)
parseField = (ParseErrorBundle Text (ErrorFancy Void) -> Maybe (Text, Text))
-> ((Text, Text) -> Maybe (Text, Text))
-> Either (ParseErrorBundle Text (ErrorFancy Void)) (Text, Text)
-> Maybe (Text, Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Text, Text)
-> ParseErrorBundle Text (ErrorFancy Void) -> Maybe (Text, Text)
forall a b. a -> b -> a
const Maybe (Text, Text)
forall a. Maybe a
Nothing) (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ParseErrorBundle Text (ErrorFancy Void)) (Text, Text)
 -> Maybe (Text, Text))
-> (Text
    -> Either (ParseErrorBundle Text (ErrorFancy Void)) (Text, Text))
-> Text
-> Maybe (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec (ErrorFancy Void) Text (Text, Text)
-> ErrorMsg
-> Text
-> Either (ParseErrorBundle Text (ErrorFancy Void)) (Text, Text)
forall e s a.
Parsec e s a -> ErrorMsg -> s -> Either (ParseErrorBundle s e) a
runParser Parsec (ErrorFancy Void) Text (Text, Text)
parser ErrorMsg
""
    parser :: Parser (Text,Text)
    parser :: Parsec (ErrorFancy Void) Text (Text, Text)
parser = do
      ParsecT (ErrorFancy Void) Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
      Text
fname <- ParsecT (ErrorFancy Void) Text Identity Text
term
      ParsecT (ErrorFancy Void) Text Identity [Token Text]
-> ParsecT (ErrorFancy Void) Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT (ErrorFancy Void) Text Identity [Token Text]
 -> ParsecT (ErrorFancy Void) Text Identity ())
-> ParsecT (ErrorFancy Void) Text Identity [Token Text]
-> ParsecT (ErrorFancy Void) Text Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT (ErrorFancy Void) Text Identity (Token Text)
-> ParsecT (ErrorFancy Void) Text Identity [Token Text]
forall a.
ParsecT (ErrorFancy Void) Text Identity a
-> ParsecT (ErrorFancy Void) Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT (ErrorFancy Void) Text Identity (Token Text)
 -> ParsecT (ErrorFancy Void) Text Identity [Token Text])
-> ParsecT (ErrorFancy Void) Text Identity (Token Text)
-> ParsecT (ErrorFancy Void) Text Identity [Token Text]
forall a b. (a -> b) -> a -> b
$ (Token Text -> Bool)
-> ParsecT (ErrorFancy Void) Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isSep
      Text
fval <- ParsecT (ErrorFancy Void) Text Identity Text
term
      (Text, Text) -> Parsec (ErrorFancy Void) Text (Text, Text)
forall a. a -> ParsecT (ErrorFancy Void) Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
fname, Text
fval)
      where
        isSep :: Char -> Bool
isSep Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c
        term :: ParsecT (ErrorFancy Void) Text Identity Text
term = (ErrorMsg -> Text)
-> ParsecT (ErrorFancy Void) Text Identity ErrorMsg
-> ParsecT (ErrorFancy Void) Text Identity Text
forall a b.
(a -> b)
-> ParsecT (ErrorFancy Void) Text Identity a
-> ParsecT (ErrorFancy Void) Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ErrorMsg -> Text
T.pack (ParsecT (ErrorFancy Void) Text Identity ErrorMsg
 -> ParsecT (ErrorFancy Void) Text Identity Text)
-> ParsecT (ErrorFancy Void) Text Identity ErrorMsg
-> ParsecT (ErrorFancy Void) Text Identity Text
forall a b. (a -> b) -> a -> b
$ ParsecT (ErrorFancy Void) Text Identity Char
-> ParsecT (ErrorFancy Void) Text Identity ErrorMsg
forall a.
ParsecT (ErrorFancy Void) Text Identity a
-> ParsecT (ErrorFancy Void) Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ParsecT (ErrorFancy Void) Text Identity Char
 -> ParsecT (ErrorFancy Void) Text Identity ErrorMsg)
-> ParsecT (ErrorFancy Void) Text Identity Char
-> ParsecT (ErrorFancy Void) Text Identity ErrorMsg
forall a b. (a -> b) -> a -> b
$ (Token Text -> Bool)
-> ParsecT (ErrorFancy Void) Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSep)