[LIGO-41] Ligo binary integration
Problem: We want to integrate our lsp client with ligo binary to be able to typecheck declarations as well as extract their scopes. Solution: Implement a simple client that calls ligo and some helpers functions to extract scopes from its output.
This commit is contained in:
Anton Myasnikov
parent
7c43cd9574
commit
d5154dff36
@ -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
|
||||
|
||||
175
tools/lsp/squirrel/src/Cli/Impl.hs
Normal file
175
tools/lsp/squirrel/src/Cli/Impl.hs
Normal file
@ -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
|
||||
189
tools/lsp/squirrel/src/Cli/Json.hs
Normal file
189
tools/lsp/squirrel/src/Cli/Json.hs
Normal file
@ -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": [ <name>, 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": [ <type>, 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"
|
||||
20
tools/lsp/squirrel/src/Cli/Types.hs
Normal file
20
tools/lsp/squirrel/src/Cli/Types.hs
Normal file
@ -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)
|
||||
Loading…
Reference in New Issue
Block a user