[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.

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

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

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": [ <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"

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)