-- |
-- Module: Staversion.Internal.Exec
-- Description: executable
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- __This is an internal module. End-users should not use it.__
module Staversion.Internal.Exec
       ( main,
         processCommand,
         -- * Only for testing
         _processCommandWithCustomBuildPlanManager
       ) where

import Control.Applicative ((<$>))
import Control.Monad (mapM_, when)
import Control.Monad.IO.Class (liftIO)
import Data.Either (rights)
import Data.Function (on)
import Data.List (groupBy, nub)
import Data.Maybe (isJust)
import Data.Text (unpack, pack)
import qualified Data.Text.Lazy.IO as TLIO

import Staversion.Internal.Aggregate (aggregateResults)
import Staversion.Internal.BuildPlan
  ( BuildPlan, packageVersion, buildPlanSource,
    newBuildPlanManager, loadBuildPlan,
    BuildPlanManager, manStackConfig
  )
import Staversion.Internal.Command
  ( parseCommandArgs,
    Command(..)
  )
import Staversion.Internal.EIO (EIO, runEIO, toEIO)
import Staversion.Internal.Format (formatAggregatedResults)
import qualified Staversion.Internal.Format as Format
import Staversion.Internal.Log (logDebug, logError, logWarn, Logger, putLogEntry)
import Staversion.Internal.Query
  ( Query(..), PackageSource(..), PackageName, ErrorMsg
  )
import Staversion.Internal.Result
  ( Result(..), ResultBody, ResultBody'(..), ResultSource(..),
    singletonResult
  )
import Staversion.Internal.Cabal (BuildDepends(..), loadCabalFile)
import Staversion.Internal.StackConfig
  ( StackConfig, newStackConfig, scCommand, readProjectCabals
  )

main :: IO ()
main :: IO ()
main = do
  Command
comm <- IO Command
parseCommandArgs
  Command -> [AggregatedResult] -> IO ()
formatAndShow Command
comm forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Command -> [Result] -> IO [AggregatedResult]
aggregate Command
comm forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Command -> IO [Result]
processCommand Command
comm)
  where
    aggregate :: Command -> [Result] -> IO [AggregatedResult]
aggregate Command
comm [Result]
results = case Command -> Maybe Aggregator
commAggregator Command
comm of
      Maybe Aggregator
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Result -> AggregatedResult
singletonResult [Result]
results
      Just Aggregator
agg -> do
        Logger -> ErrorMsg -> IO ()
logDebug (Command -> Logger
commLogger Command
comm) (ErrorMsg
"Results before aggregation: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ErrorMsg
show [Result]
results)
        let ([AggregatedResult]
aresults, [LogEntry]
logs) = Aggregator -> [Result] -> ([AggregatedResult], [LogEntry])
aggregateResults Aggregator
agg [Result]
results
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> LogEntry -> IO ()
putLogEntry forall a b. (a -> b) -> a -> b
$ Command -> Logger
commLogger Command
comm) [LogEntry]
logs
        forall (m :: * -> *) a. Monad m => a -> m a
return [AggregatedResult]
aresults
    formatAndShow :: Command -> [AggregatedResult] -> IO ()
formatAndShow Command
comm [AggregatedResult]
aresults = do
      Text -> IO ()
TLIO.putStr forall a b. (a -> b) -> a -> b
$ FormatConfig -> [AggregatedResult] -> Text
formatAggregatedResults (Command -> FormatConfig
commFormatConfig Command
comm) [AggregatedResult]
aresults

data ResolvedQuery = RQueryOne PackageName
                   | RQueryCabal FilePath BuildDepends
                   deriving (Int -> ResolvedQuery -> ShowS
[ResolvedQuery] -> ShowS
ResolvedQuery -> ErrorMsg
forall a.
(Int -> a -> ShowS) -> (a -> ErrorMsg) -> ([a] -> ShowS) -> Show a
showList :: [ResolvedQuery] -> ShowS
$cshowList :: [ResolvedQuery] -> ShowS
show :: ResolvedQuery -> ErrorMsg
$cshow :: ResolvedQuery -> ErrorMsg
showsPrec :: Int -> ResolvedQuery -> ShowS
$cshowsPrec :: Int -> ResolvedQuery -> ShowS
Show, ResolvedQuery -> ResolvedQuery -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResolvedQuery -> ResolvedQuery -> Bool
$c/= :: ResolvedQuery -> ResolvedQuery -> Bool
== :: ResolvedQuery -> ResolvedQuery -> Bool
$c== :: ResolvedQuery -> ResolvedQuery -> Bool
Eq, Eq ResolvedQuery
ResolvedQuery -> ResolvedQuery -> Bool
ResolvedQuery -> ResolvedQuery -> Ordering
ResolvedQuery -> ResolvedQuery -> ResolvedQuery
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 :: ResolvedQuery -> ResolvedQuery -> ResolvedQuery
$cmin :: ResolvedQuery -> ResolvedQuery -> ResolvedQuery
max :: ResolvedQuery -> ResolvedQuery -> ResolvedQuery
$cmax :: ResolvedQuery -> ResolvedQuery -> ResolvedQuery
>= :: ResolvedQuery -> ResolvedQuery -> Bool
$c>= :: ResolvedQuery -> ResolvedQuery -> Bool
> :: ResolvedQuery -> ResolvedQuery -> Bool
$c> :: ResolvedQuery -> ResolvedQuery -> Bool
<= :: ResolvedQuery -> ResolvedQuery -> Bool
$c<= :: ResolvedQuery -> ResolvedQuery -> Bool
< :: ResolvedQuery -> ResolvedQuery -> Bool
$c< :: ResolvedQuery -> ResolvedQuery -> Bool
compare :: ResolvedQuery -> ResolvedQuery -> Ordering
$ccompare :: ResolvedQuery -> ResolvedQuery -> Ordering
Ord)

processCommand :: Command -> IO [Result]
processCommand :: Command -> IO [Result]
processCommand = (BuildPlanManager -> IO BuildPlanManager) -> Command -> IO [Result]
_processCommandWithCustomBuildPlanManager forall (m :: * -> *) a. Monad m => a -> m a
return

stackConfigFromCommand :: Command -> StackConfig
stackConfigFromCommand :: Command -> StackConfig
stackConfigFromCommand Command
comm = (Logger -> StackConfig
newStackConfig forall a b. (a -> b) -> a -> b
$ Command -> Logger
commLogger Command
comm) { scCommand :: ErrorMsg
scCommand = Command -> ErrorMsg
commStackCommand Command
comm }

makeBuildPlanManager :: Command -> IO BuildPlanManager
makeBuildPlanManager :: Command -> IO BuildPlanManager
makeBuildPlanManager Command
comm = do
  BuildPlanManager
man <- ErrorMsg -> Logger -> Bool -> IO BuildPlanManager
newBuildPlanManager (Command -> ErrorMsg
commBuildPlanDir Command
comm) (Command -> Logger
commLogger Command
comm) (Command -> Bool
commAllowNetwork Command
comm)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BuildPlanManager
man { manStackConfig :: StackConfig
manStackConfig = Command -> StackConfig
stackConfigFromCommand Command
comm }

_processCommandWithCustomBuildPlanManager :: (BuildPlanManager -> IO BuildPlanManager) -> Command -> IO [Result]
_processCommandWithCustomBuildPlanManager :: (BuildPlanManager -> IO BuildPlanManager) -> Command -> IO [Result]
_processCommandWithCustomBuildPlanManager BuildPlanManager -> IO BuildPlanManager
customBPM Command
comm = IO [Result]
impl where
  impl :: IO [Result]
impl = do
    BuildPlanManager
bp_man <- BuildPlanManager -> IO BuildPlanManager
customBPM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Command -> IO BuildPlanManager
makeBuildPlanManager Command
comm
    [(Query, Either ErrorMsg ResolvedQuery)]
query_pairs <- Logger
-> StackConfig
-> [Query]
-> IO [(Query, Either ErrorMsg ResolvedQuery)]
resolveQueries' Logger
logger StackConfig
stack_conf forall a b. (a -> b) -> a -> b
$ Command -> [Query]
commQueries Command
comm
    [Result]
results <- 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 (BuildPlanManager
-> [(Query, Either ErrorMsg ResolvedQuery)]
-> PackageSource
-> IO [Result]
processQueriesIn BuildPlanManager
bp_man [(Query, Either ErrorMsg ResolvedQuery)]
query_pairs) forall a b. (a -> b) -> a -> b
$ Command -> [PackageSource]
commSources Command
comm
    forall {a}. [a] -> IO ()
warnEmpty [Result]
results
    forall (m :: * -> *) a. Monad m => a -> m a
return [Result]
results
  logger :: Logger
logger = Command -> Logger
commLogger Command
comm
  stack_conf :: StackConfig
stack_conf = Command -> StackConfig
stackConfigFromCommand Command
comm
  processQueriesIn :: BuildPlanManager
-> [(Query, Either ErrorMsg ResolvedQuery)]
-> PackageSource
-> IO [Result]
processQueriesIn BuildPlanManager
bp_man [(Query, Either ErrorMsg ResolvedQuery)]
query_pairs PackageSource
source = do
    let queried_names :: [PackageName]
queried_names = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ResolvedQuery -> [PackageName]
getQueriedPackageNames) forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
rights forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ [(Query, Either ErrorMsg ResolvedQuery)]
query_pairs
    Logger -> ErrorMsg -> IO ()
logDebug Logger
logger (ErrorMsg
"Retrieve package source " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ErrorMsg
show PackageSource
source)
    Either ErrorMsg BuildPlan
e_build_plan <- BuildPlanManager
-> [PackageName] -> PackageSource -> IO (Either ErrorMsg BuildPlan)
loadBuildPlan BuildPlanManager
bp_man [PackageName]
queried_names PackageSource
source
    forall {b}. Either ErrorMsg b -> IO ()
logBuildPlanResult Either ErrorMsg BuildPlan
e_build_plan
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (PackageSource
-> Either ErrorMsg BuildPlan
-> (Query, Either ErrorMsg ResolvedQuery)
-> Result
makeResult PackageSource
source Either ErrorMsg BuildPlan
e_build_plan) forall a b. (a -> b) -> a -> b
$ [(Query, Either ErrorMsg ResolvedQuery)]
query_pairs
  makeResult :: PackageSource
-> Either ErrorMsg BuildPlan
-> (Query, Either ErrorMsg ResolvedQuery)
-> Result
makeResult PackageSource
source Either ErrorMsg BuildPlan
e_build_plan (Query
orig_query, Either ErrorMsg ResolvedQuery
e_rquery) = case (Either ErrorMsg BuildPlan
e_build_plan, Either ErrorMsg ResolvedQuery
e_rquery) of
    (Left ErrorMsg
error_msg, Either ErrorMsg ResolvedQuery
_) -> Either ErrorMsg ResultBody -> Result
resultForBody forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ErrorMsg
error_msg
    (Right BuildPlan
_, Left ErrorMsg
error_msg) -> Either ErrorMsg ResultBody -> Result
resultForBody forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ErrorMsg
error_msg
    (Right BuildPlan
build_plan, Right ResolvedQuery
rquery) -> Either ErrorMsg ResultBody -> Result
resultForBody forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ BuildPlan -> ResolvedQuery -> ResultBody
searchVersions BuildPlan
build_plan ResolvedQuery
rquery
    where
      resultForBody :: Either ErrorMsg ResultBody -> Result
resultForBody Either ErrorMsg ResultBody
body =
        Result { resultIn :: ResultSource
resultIn = ResultSource { resultSourceQueried :: PackageSource
resultSourceQueried = PackageSource
source,
                                           resultSourceReal :: Maybe PackageSource
resultSourceReal = forall e. Either e BuildPlan -> Maybe PackageSource
realSource Either ErrorMsg BuildPlan
e_build_plan
                                         },
                 resultFor :: Query
resultFor = Query
orig_query,
                 resultBody :: Either ErrorMsg ResultBody
resultBody = Either ErrorMsg ResultBody
body
               }
  logBuildPlanResult :: Either ErrorMsg b -> IO ()
logBuildPlanResult (Right b
_) = Logger -> ErrorMsg -> IO ()
logDebug Logger
logger (ErrorMsg
"Successfully retrieved build plan.")
  logBuildPlanResult (Left ErrorMsg
error_msg) = Logger -> ErrorMsg -> IO ()
logError Logger
logger (ErrorMsg
"Failed to load build plan: " forall a. [a] -> [a] -> [a]
++ ErrorMsg
error_msg)
  warnEmpty :: [a] -> IO ()
warnEmpty [] = Logger -> ErrorMsg -> IO ()
logWarn Logger
logger ErrorMsg
"Got no result. Try --help option."
  warnEmpty [a]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

realSource :: Either e BuildPlan -> Maybe PackageSource
realSource :: forall e. Either e BuildPlan -> Maybe PackageSource
realSource (Left e
_) = forall a. Maybe a
Nothing
realSource (Right BuildPlan
bp) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ BuildPlan -> PackageSource
buildPlanSource BuildPlan
bp

resolveQueries' :: Logger -> StackConfig -> [Query] -> IO [(Query, Either ErrorMsg ResolvedQuery)]
resolveQueries' :: Logger
-> StackConfig
-> [Query]
-> IO [(Query, Either ErrorMsg ResolvedQuery)]
resolveQueries' Logger
logger StackConfig
sconf [Query]
queries = 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 Query -> IO [(Query, Either ErrorMsg ResolvedQuery)]
resolveToList [Query]
queries where
  resolveToList :: Query -> IO [(Query, Either ErrorMsg ResolvedQuery)]
resolveToList Query
query = do
    Either ErrorMsg [ResolvedQuery]
eret <- Logger
-> StackConfig -> Query -> IO (Either ErrorMsg [ResolvedQuery])
resolveQuery Logger
logger StackConfig
sconf Query
query
    case Either ErrorMsg [ResolvedQuery]
eret of
     Right [ResolvedQuery]
rqueries -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ResolvedQuery
rq -> (Query
query, forall a b. b -> Either a b
Right ResolvedQuery
rq)) [ResolvedQuery]
rqueries
     Left ErrorMsg
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(Query
query, forall a b. a -> Either a b
Left ErrorMsg
err)]

resolveQuery :: Logger -> StackConfig -> Query -> IO (Either ErrorMsg [ResolvedQuery])
resolveQuery :: Logger
-> StackConfig -> Query -> IO (Either ErrorMsg [ResolvedQuery])
resolveQuery Logger
logger StackConfig
sconf Query
query = forall {b}. Either ErrorMsg b -> IO (Either ErrorMsg b)
reportError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a. EIO a -> IO (Either ErrorMsg a)
runEIO forall a b. (a -> b) -> a -> b
$ Logger -> StackConfig -> Query -> EIO [ResolvedQuery]
resolveQueryEIO Logger
logger StackConfig
sconf Query
query)
  where
    reportError :: Either ErrorMsg b -> IO (Either ErrorMsg b)
reportError Either ErrorMsg b
eret = do
      case Either ErrorMsg b
eret of
       Left ErrorMsg
err -> Logger -> ErrorMsg -> IO ()
logError Logger
logger ErrorMsg
err
       Right b
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      forall (m :: * -> *) a. Monad m => a -> m a
return Either ErrorMsg b
eret

resolveQueryEIO :: Logger -> StackConfig -> Query -> EIO [ResolvedQuery]
resolveQueryEIO :: Logger -> StackConfig -> Query -> EIO [ResolvedQuery]
resolveQueryEIO Logger
logger StackConfig
sconf Query
query =
  case Query
query of
   QueryName PackageName
name -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [PackageName -> ResolvedQuery
RQueryOne PackageName
name]
   QueryCabalFile ErrorMsg
file -> ErrorMsg -> EIO [ResolvedQuery]
doCabalFile ErrorMsg
file
   QueryStackYaml ErrorMsg
file -> Maybe ErrorMsg -> EIO [ResolvedQuery]
doStackYaml (forall a. a -> Maybe a
Just ErrorMsg
file)
   Query
QueryStackYamlDefault -> Maybe ErrorMsg -> EIO [ResolvedQuery]
doStackYaml forall a. Maybe a
Nothing
  where
    doCabalFile :: ErrorMsg -> EIO [ResolvedQuery]
doCabalFile ErrorMsg
file = do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> ErrorMsg -> IO ()
logDebug Logger
logger (ErrorMsg
"Load " forall a. [a] -> [a] -> [a]
++ ErrorMsg
file forall a. [a] -> [a] -> [a]
++ ErrorMsg
" for build-depends fields.")
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ErrorMsg -> [BuildDepends] -> [ResolvedQuery]
processBuildDependsList ErrorMsg
file) forall a b. (a -> b) -> a -> b
$ forall a. IO (Either ErrorMsg a) -> EIO a
toEIO forall a b. (a -> b) -> a -> b
$ ErrorMsg -> IO (Either ErrorMsg [BuildDepends])
loadCabalFile ErrorMsg
file
    processBuildDependsList :: ErrorMsg -> [BuildDepends] -> [ResolvedQuery]
processBuildDependsList ErrorMsg
file = forall a b. (a -> b) -> [a] -> [b]
map (ErrorMsg -> BuildDepends -> ResolvedQuery
RQueryCabal ErrorMsg
file) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((Int
0 forall a. Ord a => a -> a -> Bool
<) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildDepends -> [PackageName]
depsPackages)
    doStackYaml :: Maybe ErrorMsg -> EIO [ResolvedQuery]
doStackYaml Maybe ErrorMsg
mstack_yaml = 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 ErrorMsg -> EIO [ResolvedQuery]
recurse forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a. IO (Either ErrorMsg a) -> EIO a
toEIO forall a b. (a -> b) -> a -> b
$ StackConfig -> Maybe ErrorMsg -> IO (Either ErrorMsg [ErrorMsg])
readProjectCabals StackConfig
sconf Maybe ErrorMsg
mstack_yaml)
      where
        recurse :: ErrorMsg -> EIO [ResolvedQuery]
recurse ErrorMsg
f = Logger -> StackConfig -> Query -> EIO [ResolvedQuery]
resolveQueryEIO Logger
logger StackConfig
sconf (ErrorMsg -> Query
QueryCabalFile ErrorMsg
f)

searchVersions :: BuildPlan -> ResolvedQuery -> ResultBody
searchVersions :: BuildPlan -> ResolvedQuery -> ResultBody
searchVersions BuildPlan
build_plan (RQueryOne PackageName
package_name) = forall a. PackageName -> a -> ResultBody' a
SimpleResultBody PackageName
package_name forall a b. (a -> b) -> a -> b
$ forall t. HasVersions t => t -> PackageName -> Maybe Version
packageVersion BuildPlan
build_plan PackageName
package_name
searchVersions BuildPlan
build_plan (RQueryCabal ErrorMsg
cabal_file BuildDepends
build_deps) = forall a. ErrorMsg -> Target -> [(PackageName, a)] -> ResultBody' a
CabalResultBody ErrorMsg
cabal_file Target
target [(PackageName, Maybe Version)]
ret_list where
  target :: Target
target = BuildDepends -> Target
depsTarget BuildDepends
build_deps
  ret_list :: [(PackageName, Maybe Version)]
ret_list = forall a b. (a -> b) -> [a] -> [b]
map (\PackageName
pname -> (PackageName
pname, forall t. HasVersions t => t -> PackageName -> Maybe Version
packageVersion BuildPlan
build_plan PackageName
pname)) forall a b. (a -> b) -> a -> b
$ BuildDepends -> [PackageName]
depsPackages BuildDepends
build_deps

getQueriedPackageNames :: ResolvedQuery -> [PackageName]
getQueriedPackageNames :: ResolvedQuery -> [PackageName]
getQueriedPackageNames (RQueryOne PackageName
n) = [PackageName
n]
getQueriedPackageNames (RQueryCabal ErrorMsg
_ BuildDepends
bd) = BuildDepends -> [PackageName]
depsPackages BuildDepends
bd