CLI.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HQ.CLI (CLIOptions (..), optParserInfo, runCLI, renderIOError, withInput) where

import Control.Exception (IOException, catch)
import Data.Aeson (Value)
import Data.FileEmbed (embedStringFile, makeRelativeToProject)
import Data.Text.IO (hPutStrLn)
import Data.Version (showVersion)
import HQ.JSON.Encoder (Join (..), Raw (..))
import HQ.JSON.Encoder qualified as Enc
import HQ.JSON.Parser (parseValue)
import HQ.Optic (Optic)
import HQ.Optic.Parser (parseOptic)
import HQ.Query
import HQ.Runner (executeRunnerAction, jsonRunner)
import HQ.Transformation (Transformation (..))
import HQ.Transformation.Parser (parseTransformation)
import Options.Applicative hiding (Const)
import Paths_hq_json (version)
import Relude hiding (Const)
import System.IO hiding (hPutStrLn, hSetBuffering)
import Text.Megaparsec (errorBundlePretty)

data CLIOptions = CLIOptions
  { optQuery :: Query,
    optFile :: Maybe FilePath,
    optRaw :: Raw,
    optCompact :: Enc.EncodeStyle,
    optJoin :: Join
  }

opticReader :: ReadM Optic
opticReader = eitherReader $ first errorBundlePretty . parseOptic . toText

valueReader :: ReadM Value
valueReader = eitherReader $ parseValue . toText

transformationReader :: ReadM Transformation
transformationReader =
  eitherReader $ first errorBundlePretty . parseTransformation . toText

queryParser :: Parser Query
queryParser =
  hsubparser
    $ command "fold" (info (Fold <$> opticArg) mempty)
    <> command "preview" (info (Preview <$> opticArg) mempty)
    <> command "set" (info (Over <$> opticArg <*> (Const <$> valueArg)) mempty)
    <> command "over" (info (Over <$> opticArg <*> transformationArg) mempty)
    <> command "delete" (info (Delete <$> opticArg) mempty)
  where
    opticArg = argument opticReader $ metavar "OPTIC"
    valueArg = argument valueReader $ metavar "VALUE"
    transformationArg = argument transformationReader $ metavar "TRANSFORMATION"

optParser :: Parser CLIOptions
optParser = do
  file <- optional $ strOption fileMod
  raw <- bool NoRaw Raw <$> switch rawMod
  compact <- bool (Enc.Pretty 2) Enc.Compact <$> switch compactMod
  join' <- bool NoJoin Join <$> switch joinMod
  query <- queryParser
  pure $ CLIOptions query file raw compact join'
  where
    fileHelp = "Input JSON file, or '-' for stdin"
    fileMod = long "file" <> short 'f' <> metavar "FILE" <> help fileHelp
    rawMod = long "raw" <> short 'r' <> help "Print strings without JSON quotes"
    compactMod = long "compact" <> short 'c' <> help "Print compact JSON"
    joinMod = long "join" <> short 'j' <> help "Print without separators"

langHelp :: String
langHelp = $(embedStringFile =<< makeRelativeToProject "./docs/LANG.md")

optParserInfo :: ParserInfo CLIOptions
optParserInfo = info (optParser <**> helper) infoMod
  where
    infoMod =
      mconcat
        [ fullDesc,
          progDesc headerMsg,
          header description,
          footerDoc $ Just $ fromString langHelp
        ]
    headerMsg = "Query JSON using optics"
    description = "hq v" <> showVersion version

-- | Open the input and run the query over it: stdin for 'Nothing' and
-- @-@, a file otherwise. An unopenable file is a CLI-level failure,
-- reported on stderr.
withInput :: Maybe FilePath -> (Handle -> IO a) -> IO a
withInput Nothing useHandle = useHandle stdin
withInput (Just "-") useHandle = useHandle stdin
withInput (Just path) useHandle =
  catch open $ \err -> do
    hPutStrLn stderr (renderIOError err)
    exitFailure
  where
    open = withFile path ReadMode $ \h -> do
      hSetBuffering h $ BlockBuffering Nothing
      hSetBinaryMode h True
      useHandle h

-- | Render an I/O failure for the CLI boundary, prefixed like every
-- other hq error.
renderIOError :: IOException -> Text
renderIOError err = "hq: " <> toText (displayException err)

runCLI :: IO ()
runCLI = do
  CLIOptions {..} <- execParser optParserInfo
  query <- case typecheckQuery optQuery of
    Left err -> hPutStrLn stderr (renderTypeError err) >> exitFailure
    Right q -> pure q
  let cfg = Enc.EncoderConfig optCompact $ Enc.ValueOptions optRaw optJoin
  withInput optFile $ executeRunnerAction jsonRunner query cfg