module Staversion.Internal.StackConfig
(
StackConfig,
newStackConfig,
scCommand,
readResolver,
readProjectCabals,
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)
data StackConfig =
StackConfig
{ StackConfig -> ErrorMsg
scCommand :: String,
StackConfig -> Logger
scLogger :: Logger
}
newStackConfig :: Logger -> StackConfig
newStackConfig :: Logger -> StackConfig
newStackConfig = ErrorMsg -> Logger -> StackConfig
StackConfig ErrorMsg
"stack"
newtype ProjectPath = ProjectPath (Maybe FilePath)
deriving (Int -> ProjectPath -> ShowS
[ProjectPath] -> ShowS
ProjectPath -> ErrorMsg
forall a.
(Int -> a -> ShowS) -> (a -> ErrorMsg) -> ([a] -> ShowS) -> Show a
showList :: [ProjectPath] -> ShowS
$cshowList :: [ProjectPath] -> ShowS
show :: ProjectPath -> ErrorMsg
$cshow :: ProjectPath -> ErrorMsg
showsPrec :: Int -> ProjectPath -> ShowS
$cshowsPrec :: Int -> ProjectPath -> ShowS
Show,ProjectPath -> ProjectPath -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProjectPath -> ProjectPath -> Bool
$c/= :: ProjectPath -> ProjectPath -> Bool
== :: ProjectPath -> ProjectPath -> Bool
$c== :: ProjectPath -> ProjectPath -> Bool
Eq,Eq 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
min :: ProjectPath -> ProjectPath -> ProjectPath
$cmin :: ProjectPath -> ProjectPath -> ProjectPath
max :: ProjectPath -> ProjectPath -> ProjectPath
$cmax :: ProjectPath -> ProjectPath -> ProjectPath
>= :: ProjectPath -> ProjectPath -> Bool
$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
compare :: ProjectPath -> ProjectPath -> Ordering
$ccompare :: ProjectPath -> ProjectPath -> Ordering
Ord)
instance FromJSON ProjectPath where
parseJSON :: Value -> Parser ProjectPath
parseJSON (String Text
s) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> ProjectPath
ProjectPath forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> ErrorMsg
T.unpack Text
s
parseJSON (Object Object
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> ProjectPath
ProjectPath forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing
parseJSON Value
_ = forall (f :: * -> *) a. Alternative f => f a
empty
data StackYaml =
StackYaml
{ StackYaml -> ErrorMsg
stackYamlPath :: FilePath,
StackYaml -> ErrorMsg
stackYamlResolver :: Resolver,
StackYaml -> [ProjectPath]
stackYamlPackages :: [ProjectPath]
}
deriving (Int -> StackYaml -> ShowS
[StackYaml] -> ShowS
StackYaml -> ErrorMsg
forall a.
(Int -> a -> ShowS) -> (a -> ErrorMsg) -> ([a] -> ShowS) -> Show a
showList :: [StackYaml] -> ShowS
$cshowList :: [StackYaml] -> ShowS
show :: StackYaml -> ErrorMsg
$cshow :: StackYaml -> ErrorMsg
showsPrec :: Int -> StackYaml -> ShowS
$cshowsPrec :: Int -> StackYaml -> ShowS
Show,StackYaml -> StackYaml -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StackYaml -> StackYaml -> Bool
$c/= :: StackYaml -> StackYaml -> Bool
== :: StackYaml -> StackYaml -> Bool
$c== :: StackYaml -> StackYaml -> Bool
Eq,Eq 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
min :: StackYaml -> StackYaml -> StackYaml
$cmin :: StackYaml -> StackYaml -> StackYaml
max :: StackYaml -> StackYaml -> StackYaml
$cmax :: StackYaml -> StackYaml -> StackYaml
>= :: StackYaml -> StackYaml -> Bool
$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
compare :: StackYaml -> StackYaml -> Ordering
$ccompare :: StackYaml -> StackYaml -> Ordering
Ord)
instance FromJSON StackYaml where
parseJSON :: Value -> Parser StackYaml
parseJSON (Object Object
o) = ErrorMsg -> ErrorMsg -> [ProjectPath] -> StackYaml
StackYaml ErrorMsg
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"resolver") forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"packages")
parseJSON Value
_ = forall (f :: * -> *) a. Alternative f => f a
empty
readStackYaml :: FilePath -> EIO StackYaml
readStackYaml :: ErrorMsg -> EIO StackYaml
readStackYaml ErrorMsg
file = forall e a. Show e => IO (Either e a) -> EIO a
toEIOShow forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StackYaml -> StackYaml
setPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither') forall a b. (a -> b) -> a -> b
$ ErrorMsg -> IO ByteString
BS.readFile ErrorMsg
file
where
setPath :: StackYaml -> StackYaml
setPath StackYaml
sy = StackYaml
sy { stackYamlPath :: ErrorMsg
stackYamlPath = ErrorMsg
file }
findProjectCabal :: Logger -> FilePath -> ProjectPath -> IO [FilePath]
findProjectCabal :: Logger -> ErrorMsg -> ProjectPath -> IO [ErrorMsg]
findProjectCabal Logger
_ ErrorMsg
_ (ProjectPath Maybe ErrorMsg
Nothing) = 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 = forall a b. (a -> b) -> [a] -> [b]
map (\ErrorMsg
f -> ErrorMsg
project_fullpath ErrorMsg -> ShowS
</> ErrorMsg
f) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ErrorMsg -> Bool
isCabalFile [ErrorMsg]
all_files
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ErrorMsg]
result_files forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ do
Logger -> ErrorMsg -> IO ()
logWarn Logger
logger (ErrorMsg
"No .cabal file is found in " forall a. Semigroup a => a -> a -> a
<> ErrorMsg
project_fullpath)
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" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` ErrorMsg
f
findProjectCabals :: Logger
-> StackYaml
-> IO [FilePath]
findProjectCabals :: Logger -> StackYaml -> IO [ErrorMsg]
findProjectCabals Logger
logger StackYaml
stack_yaml = do
[ErrorMsg]
cabals <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Logger -> ErrorMsg -> ProjectPath -> IO [ErrorMsg]
findProjectCabal Logger
logger ErrorMsg
base_path) [ProjectPath]
packages
forall {a}. [a] -> IO ()
warnEmpty [ErrorMsg]
cabals
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 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 " forall a. Semigroup a => a -> a -> a
<> ErrorMsg
stack_yaml_path)
warnEmpty [a]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
readProjectCabals :: StackConfig
-> Maybe FilePath
-> IO (Either ErrorMsg [FilePath])
readProjectCabals :: StackConfig -> Maybe ErrorMsg -> IO (Either ErrorMsg [ErrorMsg])
readProjectCabals StackConfig
s Maybe ErrorMsg
f = forall a. EIO a -> IO (Either ErrorMsg a)
runEIO 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
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ErrorMsg
stack_yaml_file
readResolver :: StackConfig
-> Maybe FilePath
-> IO (Either ErrorMsg Resolver)
readResolver :: StackConfig -> Maybe ErrorMsg -> IO (Either ErrorMsg ErrorMsg)
readResolver StackConfig
sconf Maybe ErrorMsg
mfile = forall a. EIO a -> IO (Either ErrorMsg a)
runEIO 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 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StackYaml -> ErrorMsg
stackYamlResolver forall a b. (a -> b) -> a -> b
$ ErrorMsg -> EIO StackYaml
readStackYaml ErrorMsg
file
configLocation :: StackConfig -> EIO FilePath
configLocation :: StackConfig -> EIO ErrorMsg
configLocation StackConfig
sconfig = do
Text
pout <- StackConfig -> EIO Text
getProcessOutput StackConfig
sconfig
ErrorMsg
path <- forall a. Either ErrorMsg a -> EIO a
eitherToEIO forall a b. (a -> b) -> a -> b
$ Text -> Either ErrorMsg ErrorMsg
configLocationFromText Text
pout
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> ErrorMsg -> IO ()
logDebug Logger
logger (ErrorMsg
"Project stack config: " forall a. Semigroup a => a -> a -> a
<> ErrorMsg
path)
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 = forall a. IO (Either ErrorMsg a) -> EIO a
toEIO forall a b. (a -> b) -> a -> b
$ (ExitCode, ErrorMsg, ErrorMsg) -> IO (Either ErrorMsg Text)
handleResult 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 forall a. Semigroup a => a -> a -> a
<> ErrorMsg
" path"
cmd :: CreateProcess
cmd = ErrorMsg -> CreateProcess
shell ErrorMsg
cmd_str
warnErr :: ErrorMsg -> IO ()
warnErr ErrorMsg
err = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length ErrorMsg
err forall a. Eq a => a -> a -> Bool
/= Int
0) 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
"'" forall a. Semigroup a => a -> a -> a
<> ErrorMsg
cmd_str forall a. Semigroup a => a -> a -> a
<> ErrorMsg
"' returns non-zero exit code: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ErrorMsg
show Int
c 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (ErrorMsg
code_err forall a. Semigroup a => a -> a -> a
<> ErrorMsg
"\n" forall a. Semigroup a => a -> a -> a
<> ErrorMsg
hint)
ExitCode
_ -> do
ErrorMsg -> IO ()
warnErr ErrorMsg
err
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right 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 forall a b. (a -> b) -> a -> b
$ Text -> [ErrorMsg]
findField 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) <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Text, Text)
parseField Text
line
if Text
fname forall a. Eq a => a -> a -> Bool
== Text
fieldName
then forall (m :: * -> *) a. Monad m => a -> m a
return 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 [] = forall a b. a -> Either a b
Left (ErrorMsg
"Cannot find '" forall a. Semigroup a => a -> a -> a
<> Text -> ErrorMsg
T.unpack Text
fieldName forall a. Semigroup a => a -> a -> a
<> ErrorMsg
"' field in stack path")
toEither (ErrorMsg
r:[ErrorMsg]
_) = forall a b. b -> Either a b
Right ErrorMsg
r
parseField :: Text -> Maybe (Text, Text)
parseField :: Text -> Maybe (Text, Text)
parseField = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> ErrorMsg -> s -> Either (ParseErrorBundle s e) a
runParser Parser (Text, Text)
parser ErrorMsg
""
parser :: Parser (Text,Text)
parser :: Parser (Text, Text)
parser = do
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
Text
fname <- ParsecT (ErrorFancy Void) Text Identity Text
term
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isSep
Text
fval <- ParsecT (ErrorFancy Void) Text Identity Text
term
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
fname, Text
fval)
where
isSep :: Char -> Bool
isSep Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
':' Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c
term :: ParsecT (ErrorFancy Void) Text Identity Text
term = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ErrorMsg -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
some forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSep)