ligo/tools/lsp/squirrel/src/Cli/Impl.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE RecordWildCards #-}

-- | Module that handles ligo binary execution.
module Cli.Impl where

import Cli.Json
import Cli.Types
import Control.Exception (Exception (..), IOException, catch, throwIO)
import Control.Lens hiding ((<.>))
import Control.Monad.Catch (MonadThrow (throwM))
import Data.Aeson
import Data.Aeson.Lens
import qualified Data.ByteString.Lazy.Char8 as C8
import Data.Text
import Data.Text.Encoding (encodeUtf8)
import Duplo.Pretty
import System.Exit
import System.IO
import System.Process (readProcessWithExitCode)

----------------------------------------------------------------------------
-- Errors
----------------------------------------------------------------------------

data LigoError
  = -- | @ligo@ call unexpectedly failed (returned non-zero exit code).
    -- The error contains the error code, stdout and stderr contents.
    UnexpectedClientFailure
      Int -- ^ Exit code
      Text -- ^ stdout
      Text -- ^ stderr
  | -- Below are the errors which may fail due to some changes in ligo compiller.

    -- | Ligo compiller produced a type which we consider is malformed
    MalformedType
      Text
  | -- | Parse error occured during scope parsing.
    ScopeParseError
      Text
  | -- | Scopes from which variables are failed to extract.
    VariableExtractError
      Value
  deriving (Show) via PP LigoError

instance Exception LigoError where
  displayException = show . pp

instance Pretty LigoError where
  pp = \case
    UnexpectedClientFailure errCode output errOutput ->
      "ligo binary unexpectedly failed with error code" <+> pp errCode
        <+> ".\nStdout:\n" <.> pp output <.> "\nStderr:\n" <.> pp errOutput
    MalformedType t ->
      "ligo binary produced type which we consider malformed:\n" <.> pp t
    ScopeParseError err ->
      "ligo binary produced scope which we consider malformed:\n" <.> pp err
    VariableExtractError scopes ->
      "ligo produced scopes which we consider malformed since we cannot extract variables from it:\n" <.> text (show scopes)

----------------------------------------------------------------------------
-- Execution
----------------------------------------------------------------------------

-- | Call ligo binary.
callLigo
  :: LigoClientEnv -> [String] -> IO String
callLigo LigoClientEnv {..} args = do
  logDebug "Running: "
  readProcessWithExitCode' _lceClientPath args "" >>= \case
    (ExitSuccess, output, errOutput) ->
      output <$ logOutput output errOutput
    (ExitFailure errCode, pack -> output, pack -> errOutput) ->
      throwM $ UnexpectedClientFailure errCode output errOutput

-- output <$ logOutput output errOutput

-- | Helper that outputs debug message to stderr immediately.
logDebug :: String -> IO ()
logDebug msg = do
  hPutStrLn stderr msg
  hFlush stdout

-- | Helper that outputs message to stdout and stderr immediately.
logOutput :: String -> String -> IO ()
logOutput msg err = do
  hPutStrLn stdout msg
  hFlush stdout
  hPutStrLn stderr err
  hFlush stderr

-- | Variant of @readProcessWithExitCode@ that prints a better error in case of
-- an exception in the inner @readProcessWithExitCode@ call.
readProcessWithExitCode'
  :: FilePath
  -> [String]
  -> String
  -> IO (ExitCode, String, String)
readProcessWithExitCode' fp args inp =
  catch
    (readProcessWithExitCode fp args inp)
    handler
  where
    handler :: IOException -> IO (ExitCode, String, String)
    handler e = do
      hPutStrLn stderr errorMsg
      throwIO e

    errorMsg =
      mconcat
        [ "ERROR!! There was an error in executing `"
        , show fp
        , "` program. Is the executable available in PATH ?"
        ]

----------------------------------------------------------------------------
-- Execution
----------------------------------------------------------------------------

-- | Extract types from a ligo scope resolution file generated by
-- ```
-- ligo get-scope contract --format=json --with-types
-- ```
parseLigoTypesFor
  :: FilePath
  -> Text
  -> IO [(Text, LigoTypeFull)]
parseLigoTypesFor contractPath name = do
  output <- C8.readFile contractPath
  case eitherDecodeStrict' @Value . encodeUtf8 . pack . C8.unpack $ output of
    Left err -> throwM $ ScopeParseError (pack err)
    Right scopes -> do
      let variables = scopes ^? key "definitions" . key "variables"
      case variables of
        Nothing -> throwM $ VariableExtractError scopes
        Just variables' -> return $ extractLigoTypesFrom name variables'

-- | Get scopes from ligo compiler and extract a list of types associated with some specific variable.
getLigoTypesFor
  :: LigoClientEnv
  -> FilePath
  -> Text
  -> IO [(Text, LigoTypeFull)]
getLigoTypesFor env contractPath name = do
  output <- callLigo env ["get-scope", contractPath, "--format=json", "--with-types"]
  case eitherDecodeStrict' @Value . encodeUtf8 . pack $ output of
    Left err -> throwM $ ScopeParseError (pack err)
    Right scopes -> do
      let variables = scopes ^? key "definitions" . key "variables"
      case variables of
        Nothing -> throwM $ VariableExtractError scopes
        Just variables' -> return $ extractLigoTypesFrom name variables'

-- | Extract a list of types in scopes from aeson @Value@ for some specific declaration.
extractLigoTypesFrom :: Text -> Value -> [(Text, LigoTypeFull)]
extractLigoTypesFrom name context =
  let current =
        context
          ^@.. members
            <. filteredBy
              (key "name"
                 . _String
                 . filtered (== name))
              . key "t"
              . (_JSON :: Prism' Value LigoTypeFull)
   in -- TODO: needs research on nested scopes, currently we think that the list is
      -- flat, but if it's not, you can simply uncomment code below
      -- deeper =
      --   context
      --     ^. members
      --       . members
      --       . key "t"
      --       . to (f name)
      current -- <> deeper