-- |
-- 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 ([AggregatedResult] -> IO ()) -> IO [AggregatedResult] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Command -> [Result] -> IO [AggregatedResult]
aggregate Command
comm ([Result] -> IO [AggregatedResult])
-> IO [Result] -> IO [AggregatedResult]
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 -> [AggregatedResult] -> IO [AggregatedResult]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([AggregatedResult] -> IO [AggregatedResult])
-> [AggregatedResult] -> IO [AggregatedResult]
forall a b. (a -> b) -> a -> b
$ (Result -> AggregatedResult) -> [Result] -> [AggregatedResult]
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: " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ [Result] -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show [Result]
results)
        let ([AggregatedResult]
aresults, [LogEntry]
logs) = Aggregator -> [Result] -> ([AggregatedResult], [LogEntry])
aggregateResults Aggregator
agg [Result]
results
        (LogEntry -> IO ()) -> [LogEntry] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> LogEntry -> IO ()
putLogEntry (Logger -> LogEntry -> IO ()) -> Logger -> LogEntry -> IO ()
forall a b. (a -> b) -> a -> b
$ Command -> Logger
commLogger Command
comm) [LogEntry]
logs
        [AggregatedResult] -> IO [AggregatedResult]
forall a. a -> IO a
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 (Text -> IO ()) -> Text -> IO ()
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 -> ErrorMsg -> ErrorMsg
[ResolvedQuery] -> ErrorMsg -> ErrorMsg
ResolvedQuery -> ErrorMsg
(Int -> ResolvedQuery -> ErrorMsg -> ErrorMsg)
-> (ResolvedQuery -> ErrorMsg)
-> ([ResolvedQuery] -> ErrorMsg -> ErrorMsg)
-> Show ResolvedQuery
forall a.
(Int -> a -> ErrorMsg -> ErrorMsg)
-> (a -> ErrorMsg) -> ([a] -> ErrorMsg -> ErrorMsg) -> Show a
$cshowsPrec :: Int -> ResolvedQuery -> ErrorMsg -> ErrorMsg
showsPrec :: Int -> ResolvedQuery -> ErrorMsg -> ErrorMsg
$cshow :: ResolvedQuery -> ErrorMsg
show :: ResolvedQuery -> ErrorMsg
$cshowList :: [ResolvedQuery] -> ErrorMsg -> ErrorMsg
showList :: [ResolvedQuery] -> ErrorMsg -> ErrorMsg
Show, ResolvedQuery -> ResolvedQuery -> Bool
(ResolvedQuery -> ResolvedQuery -> Bool)
-> (ResolvedQuery -> ResolvedQuery -> Bool) -> Eq ResolvedQuery
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResolvedQuery -> ResolvedQuery -> Bool
== :: ResolvedQuery -> ResolvedQuery -> Bool
$c/= :: ResolvedQuery -> ResolvedQuery -> Bool
/= :: ResolvedQuery -> ResolvedQuery -> Bool
Eq, Eq ResolvedQuery
Eq ResolvedQuery =>
(ResolvedQuery -> ResolvedQuery -> Ordering)
-> (ResolvedQuery -> ResolvedQuery -> Bool)
-> (ResolvedQuery -> ResolvedQuery -> Bool)
-> (ResolvedQuery -> ResolvedQuery -> Bool)
-> (ResolvedQuery -> ResolvedQuery -> Bool)
-> (ResolvedQuery -> ResolvedQuery -> ResolvedQuery)
-> (ResolvedQuery -> ResolvedQuery -> ResolvedQuery)
-> Ord 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
$ccompare :: ResolvedQuery -> ResolvedQuery -> Ordering
compare :: ResolvedQuery -> ResolvedQuery -> Ordering
$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
>= :: ResolvedQuery -> ResolvedQuery -> Bool
$cmax :: ResolvedQuery -> ResolvedQuery -> ResolvedQuery
max :: ResolvedQuery -> ResolvedQuery -> ResolvedQuery
$cmin :: ResolvedQuery -> ResolvedQuery -> ResolvedQuery
min :: ResolvedQuery -> ResolvedQuery -> ResolvedQuery
Ord)

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

stackConfigFromCommand :: Command -> StackConfig
stackConfigFromCommand :: Command -> StackConfig
stackConfigFromCommand Command
comm = (Logger -> StackConfig
newStackConfig (Logger -> StackConfig) -> Logger -> StackConfig
forall a b. (a -> b) -> a -> b
$ Command -> Logger
commLogger Command
comm) { scCommand = commStackCommand 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)
  BuildPlanManager -> IO BuildPlanManager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildPlanManager -> IO BuildPlanManager)
-> BuildPlanManager -> IO BuildPlanManager
forall a b. (a -> b) -> a -> b
$ BuildPlanManager
man { manStackConfig = stackConfigFromCommand 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 (BuildPlanManager -> IO BuildPlanManager)
-> IO BuildPlanManager -> IO BuildPlanManager
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 ([Query] -> IO [(Query, Either ErrorMsg ResolvedQuery)])
-> [Query] -> IO [(Query, Either ErrorMsg ResolvedQuery)]
forall a b. (a -> b) -> a -> b
$ Command -> [Query]
commQueries Command
comm
    [Result]
results <- ([[Result]] -> [Result]) -> IO [[Result]] -> IO [Result]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Result]] -> [Result]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[Result]] -> IO [Result]) -> IO [[Result]] -> IO [Result]
forall a b. (a -> b) -> a -> b
$ (PackageSource -> IO [Result]) -> [PackageSource] -> IO [[Result]]
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 (BuildPlanManager
-> [(Query, Either ErrorMsg ResolvedQuery)]
-> PackageSource
-> IO [Result]
processQueriesIn BuildPlanManager
bp_man [(Query, Either ErrorMsg ResolvedQuery)]
query_pairs) ([PackageSource] -> IO [[Result]])
-> [PackageSource] -> IO [[Result]]
forall a b. (a -> b) -> a -> b
$ Command -> [PackageSource]
commSources Command
comm
    [Result] -> IO ()
forall {a}. [a] -> IO ()
warnEmpty [Result]
results
    [Result] -> IO [Result]
forall a. a -> IO a
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 = [PackageName] -> [PackageName]
forall a. Eq a => [a] -> [a]
nub ([PackageName] -> [PackageName]) -> [PackageName] -> [PackageName]
forall a b. (a -> b) -> a -> b
$ [[PackageName]] -> [PackageName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PackageName]] -> [PackageName])
-> [[PackageName]] -> [PackageName]
forall a b. (a -> b) -> a -> b
$ (ResolvedQuery -> [PackageName])
-> [ResolvedQuery] -> [[PackageName]]
forall a b. (a -> b) -> [a] -> [b]
map (ResolvedQuery -> [PackageName]
getQueriedPackageNames) ([ResolvedQuery] -> [[PackageName]])
-> [ResolvedQuery] -> [[PackageName]]
forall a b. (a -> b) -> a -> b
$ [Either ErrorMsg ResolvedQuery] -> [ResolvedQuery]
forall a b. [Either a b] -> [b]
rights ([Either ErrorMsg ResolvedQuery] -> [ResolvedQuery])
-> [Either ErrorMsg ResolvedQuery] -> [ResolvedQuery]
forall a b. (a -> b) -> a -> b
$ ((Query, Either ErrorMsg ResolvedQuery)
 -> Either ErrorMsg ResolvedQuery)
-> [(Query, Either ErrorMsg ResolvedQuery)]
-> [Either ErrorMsg ResolvedQuery]
forall a b. (a -> b) -> [a] -> [b]
map (Query, Either ErrorMsg ResolvedQuery)
-> Either ErrorMsg ResolvedQuery
forall a b. (a, b) -> b
snd ([(Query, Either ErrorMsg ResolvedQuery)]
 -> [Either ErrorMsg ResolvedQuery])
-> [(Query, Either ErrorMsg ResolvedQuery)]
-> [Either ErrorMsg ResolvedQuery]
forall a b. (a -> b) -> a -> b
$ [(Query, Either ErrorMsg ResolvedQuery)]
query_pairs
    Logger -> ErrorMsg -> IO ()
logDebug Logger
logger (ErrorMsg
"Retrieve package source " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ PackageSource -> ErrorMsg
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
    Either ErrorMsg BuildPlan -> IO ()
forall {b}. Either ErrorMsg b -> IO ()
logBuildPlanResult Either ErrorMsg BuildPlan
e_build_plan
    [Result] -> IO [Result]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Result] -> IO [Result]) -> [Result] -> IO [Result]
forall a b. (a -> b) -> a -> b
$ ((Query, Either ErrorMsg ResolvedQuery) -> Result)
-> [(Query, Either ErrorMsg ResolvedQuery)] -> [Result]
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) ([(Query, Either ErrorMsg ResolvedQuery)] -> [Result])
-> [(Query, Either ErrorMsg ResolvedQuery)] -> [Result]
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 (Either ErrorMsg ResultBody -> Result)
-> Either ErrorMsg ResultBody -> Result
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Either ErrorMsg ResultBody
forall a b. a -> Either a b
Left ErrorMsg
error_msg
    (Right BuildPlan
_, Left ErrorMsg
error_msg) -> Either ErrorMsg ResultBody -> Result
resultForBody (Either ErrorMsg ResultBody -> Result)
-> Either ErrorMsg ResultBody -> Result
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Either ErrorMsg ResultBody
forall a b. a -> Either a b
Left ErrorMsg
error_msg
    (Right BuildPlan
build_plan, Right ResolvedQuery
rquery) -> Either ErrorMsg ResultBody -> Result
resultForBody (Either ErrorMsg ResultBody -> Result)
-> Either ErrorMsg ResultBody -> Result
forall a b. (a -> b) -> a -> b
$ ResultBody -> Either ErrorMsg ResultBody
forall a b. b -> Either a b
Right (ResultBody -> Either ErrorMsg ResultBody)
-> ResultBody -> Either ErrorMsg ResultBody
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 = Either ErrorMsg BuildPlan -> Maybe PackageSource
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: " ErrorMsg -> ErrorMsg -> ErrorMsg
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]
_ = () -> IO ()
forall a. a -> IO 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
_) = Maybe PackageSource
forall a. Maybe a
Nothing
realSource (Right BuildPlan
bp) = PackageSource -> Maybe PackageSource
forall a. a -> Maybe a
Just (PackageSource -> Maybe PackageSource)
-> PackageSource -> Maybe PackageSource
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 = ([[(Query, Either ErrorMsg ResolvedQuery)]]
 -> [(Query, Either ErrorMsg ResolvedQuery)])
-> IO [[(Query, Either ErrorMsg ResolvedQuery)]]
-> IO [(Query, Either ErrorMsg ResolvedQuery)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(Query, Either ErrorMsg ResolvedQuery)]]
-> [(Query, Either ErrorMsg ResolvedQuery)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[(Query, Either ErrorMsg ResolvedQuery)]]
 -> IO [(Query, Either ErrorMsg ResolvedQuery)])
-> IO [[(Query, Either ErrorMsg ResolvedQuery)]]
-> IO [(Query, Either ErrorMsg ResolvedQuery)]
forall a b. (a -> b) -> a -> b
$ (Query -> IO [(Query, Either ErrorMsg ResolvedQuery)])
-> [Query] -> IO [[(Query, Either ErrorMsg ResolvedQuery)]]
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 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 -> [(Query, Either ErrorMsg ResolvedQuery)]
-> IO [(Query, Either ErrorMsg ResolvedQuery)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Query, Either ErrorMsg ResolvedQuery)]
 -> IO [(Query, Either ErrorMsg ResolvedQuery)])
-> [(Query, Either ErrorMsg ResolvedQuery)]
-> IO [(Query, Either ErrorMsg ResolvedQuery)]
forall a b. (a -> b) -> a -> b
$ (ResolvedQuery -> (Query, Either ErrorMsg ResolvedQuery))
-> [ResolvedQuery] -> [(Query, Either ErrorMsg ResolvedQuery)]
forall a b. (a -> b) -> [a] -> [b]
map (\ResolvedQuery
rq -> (Query
query, ResolvedQuery -> Either ErrorMsg ResolvedQuery
forall a b. b -> Either a b
Right ResolvedQuery
rq)) [ResolvedQuery]
rqueries
     Left ErrorMsg
err -> [(Query, Either ErrorMsg ResolvedQuery)]
-> IO [(Query, Either ErrorMsg ResolvedQuery)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Query, Either ErrorMsg ResolvedQuery)]
 -> IO [(Query, Either ErrorMsg ResolvedQuery)])
-> [(Query, Either ErrorMsg ResolvedQuery)]
-> IO [(Query, Either ErrorMsg ResolvedQuery)]
forall a b. (a -> b) -> a -> b
$ [(Query
query, ErrorMsg -> Either ErrorMsg ResolvedQuery
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 = Either ErrorMsg [ResolvedQuery]
-> IO (Either ErrorMsg [ResolvedQuery])
forall {b}. Either ErrorMsg b -> IO (Either ErrorMsg b)
reportError (Either ErrorMsg [ResolvedQuery]
 -> IO (Either ErrorMsg [ResolvedQuery]))
-> IO (Either ErrorMsg [ResolvedQuery])
-> IO (Either ErrorMsg [ResolvedQuery])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (EIO [ResolvedQuery] -> IO (Either ErrorMsg [ResolvedQuery])
forall a. EIO a -> IO (Either ErrorMsg a)
runEIO (EIO [ResolvedQuery] -> IO (Either ErrorMsg [ResolvedQuery]))
-> EIO [ResolvedQuery] -> IO (Either ErrorMsg [ResolvedQuery])
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
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Either ErrorMsg b -> IO (Either ErrorMsg b)
forall a. a -> IO a
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 -> [ResolvedQuery] -> EIO [ResolvedQuery]
forall a. a -> ExceptT ErrorMsg IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ResolvedQuery] -> EIO [ResolvedQuery])
-> [ResolvedQuery] -> EIO [ResolvedQuery]
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 (ErrorMsg -> Maybe ErrorMsg
forall a. a -> Maybe a
Just ErrorMsg
file)
   Query
QueryStackYamlDefault -> Maybe ErrorMsg -> EIO [ResolvedQuery]
doStackYaml Maybe ErrorMsg
forall a. Maybe a
Nothing
  where
    doCabalFile :: ErrorMsg -> EIO [ResolvedQuery]
doCabalFile ErrorMsg
file = do
      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
"Load " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
file ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" for build-depends fields.")
      ([BuildDepends] -> [ResolvedQuery])
-> ExceptT ErrorMsg IO [BuildDepends] -> EIO [ResolvedQuery]
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 (ErrorMsg -> [BuildDepends] -> [ResolvedQuery]
processBuildDependsList ErrorMsg
file) (ExceptT ErrorMsg IO [BuildDepends] -> EIO [ResolvedQuery])
-> ExceptT ErrorMsg IO [BuildDepends] -> EIO [ResolvedQuery]
forall a b. (a -> b) -> a -> b
$ IO (Either ErrorMsg [BuildDepends])
-> ExceptT ErrorMsg IO [BuildDepends]
forall a. IO (Either ErrorMsg a) -> EIO a
toEIO (IO (Either ErrorMsg [BuildDepends])
 -> ExceptT ErrorMsg IO [BuildDepends])
-> IO (Either ErrorMsg [BuildDepends])
-> ExceptT ErrorMsg IO [BuildDepends]
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> IO (Either ErrorMsg [BuildDepends])
loadCabalFile ErrorMsg
file
    processBuildDependsList :: ErrorMsg -> [BuildDepends] -> [ResolvedQuery]
processBuildDependsList ErrorMsg
file = (BuildDepends -> ResolvedQuery)
-> [BuildDepends] -> [ResolvedQuery]
forall a b. (a -> b) -> [a] -> [b]
map (ErrorMsg -> BuildDepends -> ResolvedQuery
RQueryCabal ErrorMsg
file) ([BuildDepends] -> [ResolvedQuery])
-> ([BuildDepends] -> [BuildDepends])
-> [BuildDepends]
-> [ResolvedQuery]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildDepends -> Bool) -> [BuildDepends] -> [BuildDepends]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<) (Int -> Bool) -> (BuildDepends -> Int) -> BuildDepends -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PackageName] -> Int)
-> (BuildDepends -> [PackageName]) -> BuildDepends -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildDepends -> [PackageName]
depsPackages)
    doStackYaml :: Maybe ErrorMsg -> EIO [ResolvedQuery]
doStackYaml Maybe ErrorMsg
mstack_yaml = ([[ResolvedQuery]] -> [ResolvedQuery])
-> ExceptT ErrorMsg IO [[ResolvedQuery]] -> EIO [ResolvedQuery]
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 [[ResolvedQuery]] -> [ResolvedQuery]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (ExceptT ErrorMsg IO [[ResolvedQuery]] -> EIO [ResolvedQuery])
-> ExceptT ErrorMsg IO [[ResolvedQuery]] -> EIO [ResolvedQuery]
forall a b. (a -> b) -> a -> b
$ (ErrorMsg -> EIO [ResolvedQuery])
-> [ErrorMsg] -> ExceptT ErrorMsg IO [[ResolvedQuery]]
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 ErrorMsg -> EIO [ResolvedQuery]
recurse ([ErrorMsg] -> ExceptT ErrorMsg IO [[ResolvedQuery]])
-> ExceptT ErrorMsg IO [ErrorMsg]
-> ExceptT ErrorMsg IO [[ResolvedQuery]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IO (Either ErrorMsg [ErrorMsg]) -> ExceptT ErrorMsg IO [ErrorMsg]
forall a. IO (Either ErrorMsg a) -> EIO a
toEIO (IO (Either ErrorMsg [ErrorMsg]) -> ExceptT ErrorMsg IO [ErrorMsg])
-> IO (Either ErrorMsg [ErrorMsg])
-> ExceptT ErrorMsg IO [ErrorMsg]
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) = PackageName -> Maybe Version -> ResultBody
forall a. PackageName -> a -> ResultBody' a
SimpleResultBody PackageName
package_name (Maybe Version -> ResultBody) -> Maybe Version -> ResultBody
forall a b. (a -> b) -> a -> b
$ BuildPlan -> PackageName -> Maybe Version
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) = ErrorMsg -> Target -> [(PackageName, Maybe Version)] -> ResultBody
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 = (PackageName -> (PackageName, Maybe Version))
-> [PackageName] -> [(PackageName, Maybe Version)]
forall a b. (a -> b) -> [a] -> [b]
map (\PackageName
pname -> (PackageName
pname, BuildPlan -> PackageName -> Maybe Version
forall t. HasVersions t => t -> PackageName -> Maybe Version
packageVersion BuildPlan
build_plan PackageName
pname)) ([PackageName] -> [(PackageName, Maybe Version)])
-> [PackageName] -> [(PackageName, Maybe Version)]
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