{-# 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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [QueryException] -> ShowS
$cshowList :: [QueryException] -> ShowS
show :: QueryException -> [Char]
$cshow :: QueryException -> [Char]
showsPrec :: Int -> QueryException -> ShowS
$cshowsPrec :: Int -> 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 " forall a. [a] -> [a] -> [a]
++ 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: " forall a. [a] -> [a] -> [a]
++ [Char]
code forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++ [Char]
msg forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ 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 = forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec forall a b. (a -> b) -> a -> b
$
  forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => [Text] -> RIO env ()
queryBuildInfo forall a b. (a -> b) -> a -> b
$ 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 =
      forall env. HasEnvConfig env => RIO env Value
rawBuildInfo
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {f :: * -> *}.
MonadIO f =>
([Text] -> [Text]) -> [Text] -> Value -> f Value
select forall a. a -> a
id [Text]
selectors0
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
TIO.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
addGlobalHintsComment forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Yaml.encode
 where
  select :: ([Text] -> [Text]) -> [Text] -> Value -> f Value
select [Text] -> [Text]
_ [] Value
value = 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 forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
sel) Object
o of
          Maybe Value
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO 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 forall a. Integral a => Reader a
decimal Text
sel of
          Right (Int
i, Text
"")
            | Int
i forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
< forall a. Vector a -> Int
V.length Array
v -> Value -> f Value
cont forall a b. (a -> b) -> a -> b
$ Array
v forall a. Vector a -> Int -> a
V.! Int
i
            | Bool
otherwise -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> QueryException
IndexOutOfRange [Text]
sels'
          Either [Char] (Int, Text)
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> QueryException
NoNumericSelector [Text]
sels'
      Value
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO 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 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
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
selectors0 = Text -> Text -> Text -> Text
T.replace Text
globalHintsLine (Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
globalHintsComment 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"] forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Text]
selectors0 = (forall a. Semigroup a => a -> a -> a
<> (Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
globalHintsComment))
    | Bool
otherwise = 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 <- forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
  Text
wantedCompiler <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall s r. HasBuildConfig s => Getting r s WantedCompiler
wantedCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display)
  Text
actualCompiler <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> Text
compilerVersionText
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
    [ Key
"locals" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Object -> Value
Object (forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map LocalPackage -> Pair
localToPair [LocalPackage]
locals)
    , Key
"compiler" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
        [ Key
"wanted" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
wantedCompiler
        , Key
"actual" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
actualCompiler
        ]
    ]
 where
  localToPair :: LocalPackage -> Pair
localToPair LocalPackage
lp =
    (Text -> Key
Key.fromText forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. a -> CabalString a
CabalString (Package -> Version
packageVersion Package
p)
      , Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall b t. Path b t -> [Char]
toFilePath (forall b t. Path b t -> Path b Dir
parent forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)
      ]