{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Types and functions related to Stack's @query@ command.

module Stack.Query
  ( queryCmd
  , queryBuildInfo
  ) where

import           Data.Aeson ( Value (Object, Array), (.=), object )
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import           Data.List ( isPrefixOf )
import qualified Data.Text as T
import           Data.Text.Encoding ( decodeUtf8 )
import qualified Data.Text.IO as TIO
import           Data.Text.Read ( decimal )
import qualified Data.Vector as V
import qualified Data.Yaml as Yaml
import           Path ( parent )
import           Stack.Build.Source ( projectLocalPackages )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import           Stack.Types.BuildConfig ( wantedCompilerVersionL )
import           Stack.Types.Compiler ( compilerVersionText )
import           Stack.Types.EnvConfig ( HasEnvConfig, actualCompilerVersionL )
import           Stack.Types.Runner ( Runner )
import           Stack.Types.Package ( LocalPackage (..), Package (..) )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Query"module.

data QueryException
  = SelectorNotFound ![Text]
  | IndexOutOfRange ![Text]
  | NoNumericSelector ![Text]
  | CannotApplySelector !Value ![Text]
  deriving (Int -> QueryException -> ShowS
[QueryException] -> ShowS
QueryException -> [Char]
(Int -> QueryException -> ShowS)
-> (QueryException -> [Char])
-> ([QueryException] -> ShowS)
-> Show QueryException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueryException -> ShowS
showsPrec :: Int -> QueryException -> ShowS
$cshow :: QueryException -> [Char]
show :: QueryException -> [Char]
$cshowList :: [QueryException] -> ShowS
showList :: [QueryException] -> ShowS
Show, Typeable)

instance Exception QueryException where
  displayException :: QueryException -> [Char]
displayException (SelectorNotFound [Text]
sels) =
    [Char] -> [Char] -> [Text] -> [Char]
err [Char]
"[S-4419]" [Char]
"Selector not found" [Text]
sels
  displayException (IndexOutOfRange [Text]
sels) =
    [Char] -> [Char] -> [Text] -> [Char]
err [Char]
"[S-8422]" [Char]
"Index out of range" [Text]
sels
  displayException (NoNumericSelector [Text]
sels) =
    [Char] -> [Char] -> [Text] -> [Char]
err [Char]
"[S-4360]" [Char]
"Encountered array and needed numeric selector" [Text]
sels
  displayException (CannotApplySelector Value
value [Text]
sels) =
    [Char] -> [Char] -> [Text] -> [Char]
err [Char]
"[S-1711]" ([Char]
"Cannot apply selector to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> [Char]
forall a. Show a => a -> [Char]
show Value
value) [Text]
sels

-- | Helper function for 'QueryException' instance of 'Show'

err :: String -> String -> [Text] -> String
err :: [Char] -> [Char] -> [Text] -> [Char]
err [Char]
msg [Char]
code [Text]
sels = [Char]
"Error: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
code [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> [Char]
forall a. Show a => a -> [Char]
show [Text]
sels

-- | Function underlying the @stack query@ command.

queryCmd ::
     [String]
     -- ^ Selectors.

  -> RIO Runner ()
queryCmd :: [[Char]] -> RIO Runner ()
queryCmd [[Char]]
selectors = ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
  RIO EnvConfig () -> RIO Config ()
forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ [Text] -> RIO EnvConfig ()
forall env. HasEnvConfig env => [Text] -> RIO env ()
queryBuildInfo ([Text] -> RIO EnvConfig ()) -> [Text] -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack [[Char]]
selectors

-- | Query information about the build and print the result to stdout in YAML

-- format.

queryBuildInfo ::
     HasEnvConfig env
  => [Text] -- ^ Selectors.

  -> RIO env ()
queryBuildInfo :: forall env. HasEnvConfig env => [Text] -> RIO env ()
queryBuildInfo [Text]
selectors0 =
      RIO env Value
forall env. HasEnvConfig env => RIO env Value
rawBuildInfo
  RIO env Value -> (Value -> RIO env Value) -> RIO env Value
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> [Text]) -> [Text] -> Value -> RIO env Value
forall {f :: * -> *}.
MonadIO f =>
([Text] -> [Text]) -> [Text] -> Value -> f Value
select [Text] -> [Text]
forall a. a -> a
id [Text]
selectors0
  RIO env Value -> (Value -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> (Value -> IO ()) -> Value -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
TIO.putStrLn (Text -> IO ()) -> (Value -> Text) -> Value -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
addGlobalHintsComment (Text -> Text) -> (Value -> Text) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode
 where
  select :: ([Text] -> [Text]) -> [Text] -> Value -> f Value
select [Text] -> [Text]
_ [] Value
value = Value -> f Value
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value
  select [Text] -> [Text]
front (Text
sel:[Text]
sels) Value
value =
    case Value
value of
      Object Object
o ->
        case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
sel) Object
o of
          Maybe Value
Nothing -> QueryException -> f Value
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (QueryException -> f Value) -> QueryException -> f Value
forall a b. (a -> b) -> a -> b
$ [Text] -> QueryException
SelectorNotFound [Text]
sels'
          Just Value
value' -> Value -> f Value
cont Value
value'
      Array Array
v ->
        case Reader Int
forall a. Integral a => Reader a
decimal Text
sel of
          Right (Int
i, Text
"")
            | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Array -> Int
forall a. Vector a -> Int
V.length Array
v -> Value -> f Value
cont (Value -> f Value) -> Value -> f Value
forall a b. (a -> b) -> a -> b
$ Array
v Array -> Int -> Value
forall a. Vector a -> Int -> a
V.! Int
i
            | Bool
otherwise -> QueryException -> f Value
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (QueryException -> f Value) -> QueryException -> f Value
forall a b. (a -> b) -> a -> b
$ [Text] -> QueryException
IndexOutOfRange [Text]
sels'
          Either [Char] (Int, Text)
_ -> QueryException -> f Value
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (QueryException -> f Value) -> QueryException -> f Value
forall a b. (a -> b) -> a -> b
$ [Text] -> QueryException
NoNumericSelector [Text]
sels'
      Value
_ -> QueryException -> f Value
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (QueryException -> f Value) -> QueryException -> f Value
forall a b. (a -> b) -> a -> b
$ Value -> [Text] -> QueryException
CannotApplySelector Value
value [Text]
sels'
   where
    cont :: Value -> f Value
cont = ([Text] -> [Text]) -> [Text] -> Value -> f Value
select ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
sel:)) [Text]
sels
    sels' :: [Text]
sels' = [Text] -> [Text]
front [Text
sel]
  -- Include comments to indicate that this portion of the "stack

  -- query" API is not necessarily stable.

  addGlobalHintsComment :: Text -> Text
addGlobalHintsComment
    | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
selectors0 = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
globalHintsLine (Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
globalHintsComment Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
globalHintsLine)
    -- Append comment instead of pre-pending. The reasoning here is

    -- that something *could* expect that the result of 'stack query

    -- global-hints ghc-boot' is just a string literal. Seems easier

    -- for to expect the first line of the output to be the literal.

    | [Text
"global-hints"] [Text] -> [Text] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Text]
selectors0 = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
globalHintsComment))
    | Bool
otherwise = Text -> Text
forall a. a -> a
id
  globalHintsLine :: Text
globalHintsLine = Text
"\nglobal-hints:\n"
  globalHintsComment :: Text
globalHintsComment = [Text] -> Text
T.concat
    [ Text
"# Note: global-hints is experimental and may be renamed / removed in the future.\n"
    , Text
"# See https://github.com/commercialhaskell/stack/issues/3796"
    ]

-- | Get the raw build information object

rawBuildInfo :: HasEnvConfig env => RIO env Value
rawBuildInfo :: forall env. HasEnvConfig env => RIO env Value
rawBuildInfo = do
  [LocalPackage]
locals <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
  Text
wantedCompiler <- Getting Text env Text -> RIO env Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Text env Text -> RIO env Text)
-> Getting Text env Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ Getting Text env WantedCompiler
forall s r. HasBuildConfig s => Getting r s WantedCompiler
wantedCompilerVersionLGetting Text env WantedCompiler
-> ((Text -> Const Text Text)
    -> WantedCompiler -> Const Text WantedCompiler)
-> Getting Text env Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(WantedCompiler -> Text) -> SimpleGetter WantedCompiler Text
forall s a. (s -> a) -> SimpleGetter s a
to (Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text)
-> (WantedCompiler -> Utf8Builder) -> WantedCompiler -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WantedCompiler -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display)
  Text
actualCompiler <- Getting Text env Text -> RIO env Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Text env Text -> RIO env Text)
-> Getting Text env Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ Getting Text env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionLGetting Text env ActualCompiler
-> ((Text -> Const Text Text)
    -> ActualCompiler -> Const Text ActualCompiler)
-> Getting Text env Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ActualCompiler -> Text) -> SimpleGetter ActualCompiler Text
forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> Text
compilerVersionText
  Value -> RIO env Value
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> RIO env Value) -> Value -> RIO env Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
    [ Key
"locals" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Object -> Value
Object ([Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([Pair] -> Object) -> [Pair] -> Object
forall a b. (a -> b) -> a -> b
$ (LocalPackage -> Pair) -> [LocalPackage] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map LocalPackage -> Pair
localToPair [LocalPackage]
locals)
    , Key
"compiler" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= [Pair] -> Value
object
        [ Key
"wanted" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
wantedCompiler
        , Key
"actual" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
actualCompiler
        ]
    ]
 where
  localToPair :: LocalPackage -> Pair
localToPair LocalPackage
lp =
    (Text -> Key
Key.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString (PackageName -> [Char]) -> PackageName -> [Char]
forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
p, Value
value)
   where
    p :: Package
p = LocalPackage -> Package
lpPackage LocalPackage
lp
    value :: Value
value = [Pair] -> Value
object
      [ Key
"version" Key -> CabalString Version -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Version -> CabalString Version
forall a. a -> CabalString a
CabalString (Package -> Version
packageVersion Package
p)
      , Key
"path" Key -> [Char] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)
      ]