diff --git a/tools/lsp/squirrel/package.yaml b/tools/lsp/squirrel/package.yaml index ad8c0a5e1..c470040d4 100644 --- a/tools/lsp/squirrel/package.yaml +++ b/tools/lsp/squirrel/package.yaml @@ -67,6 +67,12 @@ library: dependencies: - haskell-lsp-types + - aeson + - process + - lens + - lens-aeson + - bytestring + - unordered-containers executables: squirrel: @@ -75,6 +81,7 @@ executables: - hslogger - interpolate - lens + - lens-aeson - ligo-squirrel - directory - unix diff --git a/tools/lsp/squirrel/src/Cli/Impl.hs b/tools/lsp/squirrel/src/Cli/Impl.hs new file mode 100644 index 000000000..645d4087c --- /dev/null +++ b/tools/lsp/squirrel/src/Cli/Impl.hs @@ -0,0 +1,175 @@ +{-# 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 diff --git a/tools/lsp/squirrel/src/Cli/Json.hs b/tools/lsp/squirrel/src/Cli/Json.hs new file mode 100644 index 000000000..364dd8b07 --- /dev/null +++ b/tools/lsp/squirrel/src/Cli/Json.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + +-- | The definition of type as is represented in ligo JSON output +module Cli.Json + ( LigoTypeFull (..) + , LigoTypeContent (..) + , LigoTypeContentInner (..) + , LigoRecordField (..) + , LigoLocation (..) + ) +where + +import Data.Aeson +import Data.Char (isUpper, toLower) +import Data.Foldable (asum, toList) +import qualified Data.HashMap.Strict as HM +import Data.Text (Text) +import GHC.Generics + +---------------------------------------------------------------------------- +-- Types +---------------------------------------------------------------------------- + +-- | Whole ligo type. +-- ``` +-- { "t" : LigoTypeFull } +-- ``` +data LigoTypeFull = LigoTypeFull + { -- | Location of the definition. + ltLocation :: LigoLocation + , -- | *Some* meta constructors (e.g. `Some`). + ltTypeMeta :: Value + , -- | We parse it by a chunks of 2, each odd element of array is a name for + -- even element which is `LigoTypeContentInner`. + -- ``` + -- { "type_content": [ , LigoTypeContentInner ] } + -- ``` + ltTypeContent :: [LigoTypeContent] + } + deriving stock (Generic, Show) + +-- | A pair in "type_content" array `[name, content]`. +-- ``` +-- { "type_content": LigoTypeContent } +-- ``` +data LigoTypeContent = LigoTypeContent + { ltcName :: Text + , ltcContentInner :: LigoTypeContentInner + } + deriving stock (Generic, Show) + +-- | Inner object representing type content that depends on `name` in `LigoTypeContent`. +-- ``` +-- { "type_content": [ , LigoTypeContentInner ] } +-- ``` +data LigoTypeContentInner + = -- | Type call represented by the list of arguments and its constructor. + LTCConst + { ltciArguments :: [Text] + , ltciTypeConst :: Value + } + | -- | Record type. + LTCRecord (HM.HashMap Text LigoRecordField) -- TODO: continue + | -- | Arrow type, note that the order of its arguments is reversed. + LTCArrow -- "type2" -> "type1" + { ltcType2 :: LigoTypeFull + , ltcType1 :: LigoTypeFull + } + deriving stock (Generic, Show) + +-- | Record field type value. +-- ``` +-- { "type_content": ["T_record", { "key": LigoRecordField } ] } +-- ``` +data LigoRecordField = LigoRecordField + { -- | Declaration position (don't ask me I too don't know what actual + -- position is this since from all the example it's somewhat always 0). + lrfDeclPos :: Int + , -- | How the value is represented in michelson, currently ignored + -- during parsing. + lrfMichelsonAnnotation :: Value + , -- | The type itself. + lrfAssociatedType :: LigoTypeFull + } + deriving stock (Generic, Show) + +-- | Location of type definition. +-- ``` +-- { "location": LigoLocation } +-- ``` +data LigoLocation + = Virtual Text + | LigoLocation + { llFile :: FilePath + , llFromRow :: Int + , llFromCol :: Int + , llToRow :: Int + , llToCol :: Int + } + deriving stock (Generic, Show) + +---------------------------------------------------------------------------- +-- Instances +---------------------------------------------------------------------------- + +-- TODO: We trust ligo compiler output for printing even number +-- of array elements. +instance FromJSON LigoTypeFull where + parseJSON = withObject "type_full" $ \o -> do + ltLocation <- o .: "location" + type_content <- o .: "type_content" + ltTypeContent <- + withArray "type_content" (mapM proceed . group 2 . toList) type_content + ltTypeMeta <- o .: "type_meta" + return $ LigoTypeFull {..} + where + proceed [name, value] = do + ltcName <- parseJSON @Text name + ltcContentInner <- parseJSON @LigoTypeContentInner value + return $ LigoTypeContent {..} + proceed _ = error "number of type content elements is not even and cannot be grouped" + +instance ToJSON LigoTypeFull where + toJSON = genericToJSON defaultOptions {fieldLabelModifier = prepareField 2} + +instance FromJSON LigoTypeContent where + parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = prepareField 3} + +instance ToJSON LigoTypeContent where + toJSON = genericToJSON defaultOptions {fieldLabelModifier = prepareField 3} + +instance FromJSON LigoTypeContentInner where + parseJSON = withObject "type_content" $ \o -> + asum + [ LTCConst <$> o .: "arguments" <*> o .: "type_constant" + , LTCRecord <$> sequence (parseJSON @LigoRecordField <$> o) + , LTCArrow <$> o .: "type2" <*> o .: "type1" + ] + +instance ToJSON LigoTypeContentInner where + toJSON = genericToJSON defaultOptions {fieldLabelModifier = prepareField 3} + +instance FromJSON LigoRecordField where + parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = prepareField 3} + +instance ToJSON LigoRecordField where + toJSON = genericToJSON defaultOptions {fieldLabelModifier = prepareField 3} + +instance FromJSON LigoLocation where + parseJSON = withObject "location" $ \o -> + asum + [ Virtual <$> o .: "virtual" + , do + llFile <- o .: "file" + llFromRow <- o .: "from_row" + llFromCol <- o .: "from_col" + llToRow <- o .: "to_row" + llToCol <- o .: "to_col" + return $ LigoLocation {..} + ] + +instance ToJSON LigoLocation where + toJSON = genericToJSON defaultOptions {fieldLabelModifier = prepareField 2} + +---------------------------------------------------------------------------- +-- Helpers +---------------------------------------------------------------------------- + +-- | Helper function that converts qualified field to its JSON counterpart. +-- +-- >>> prepareField 2 "llFooBar" +-- "foo_bar" +prepareField :: Int -> String -> String +prepareField dropAmount = Prelude.drop (dropAmount + 1) . concatMap process + where + process c + | isUpper c = "_" <> [toLower c] + | otherwise = [c] + +-- | Splits an array onto chunks of n elements, throws error otherwise. +-- +-- >>> group 2 [1, 2, 3, 4] +-- [[1,2],[3,4]] +group :: Int -> [a] -> [[a]] +group _ [] = [] +group n l + | n > 0 = (take n l) : (group n (drop n l)) + | otherwise = error "Negative or zero n" diff --git a/tools/lsp/squirrel/src/Cli/Types.hs b/tools/lsp/squirrel/src/Cli/Types.hs new file mode 100644 index 000000000..8818a7d25 --- /dev/null +++ b/tools/lsp/squirrel/src/Cli/Types.hs @@ -0,0 +1,20 @@ +-- | All the types needed for cli to work. +module Cli.Types + ( LigoClient + , LigoClientEnv (..) + ) +where + +import Control.Monad.Trans.Reader (ReaderT) + +-- | Type of the client itself. +type LigoClient = ReaderT LigoClientEnv IO + +-- | Environment passed throughout the ligo interaction +data LigoClientEnv = LigoClientEnv + { -- | Ligo binary path + _lceClientPath :: FilePath + , -- | Whether we need to print logs from ligo + _lceVerbose :: Bool + } + deriving stock (Show)