[LIGO-41] Convert ligo scopes to ScopedDecl

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

@@ -1,18 +1,24 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric, DerivingVia, RecordWildCards #-}
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE RecordWildCards #-}
 
 -- | Module that handles ligo binary execution.
-module Cli.Impl where
+module Cli.Impl
+  ( LigoError(..)
+  , callLigo
+  , parseLigoScopes
+  , parseLigoTypesFor
+  , getLigoScopesRaw
+  , getLigoScopedDecls
+  , getLigoTypesFor
+  , parseScopedDecls
+  ) 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 qualified Data.HashMap.Strict as HM
 import Data.Text
 import Data.Text.Encoding (encodeUtf8)
 import Duplo.Pretty
@@ -20,6 +26,10 @@ import System.Exit
 import System.IO
 import System.Process (readProcessWithExitCode)
 
+import AST.Scope
+import Cli.Json
+import Cli.Types
+
 ----------------------------------------------------------------------------
 -- Errors
 ----------------------------------------------------------------------------
@@ -118,13 +128,51 @@ readProcessWithExitCode' fp args inp =
 -- Execution
 ----------------------------------------------------------------------------
 
+----------------------------------------------------------------------------
+-- Parse from output file
+
+-- | Parse scope from ligo output file generated by
+-- ```
+-- ligo get-scope contract --format=json --with-types
+-- ```
+-- and return a hashmap of scope name and our internal scope declarations.
+parseScopedDecls
+  :: FilePath
+  -> IO (HM.HashMap Text ScopedDecl)
+parseScopedDecls contractPath = do
+  scopes <- parseLigoScopes contractPath
+  return $ fmap toScopedDecl scopes
+
+-- | Parse scope from ligo output file generated by
+-- ```
+-- ligo get-scope contract --format=json --with-types
+-- ```
+-- and return a hashmap of scope name and its values.
+parseLigoScopes
+  :: FilePath
+  -> IO (HM.HashMap Text LigoScope)
+parseLigoScopes contractPath =
+  let interpret :: Value -> HM.HashMap Text LigoScope
+      interpret scopes =
+        scopes
+          ^?! key "definitions" -- TODO: may error here
+            . key "variables"
+          ^@.. members
+            . (_JSON :: Prism' Value LigoScope)
+          ^. to HM.fromList
+   in do
+        output <- C8.readFile contractPath
+        case eitherDecodeStrict' @Value . encodeUtf8 . pack . C8.unpack $ output of
+          Left err -> throwM $ ScopeParseError (pack err)
+          Right scopes -> return $ interpret scopes
+
 -- | Extract types from a ligo scope resolution file generated by
 -- ```
 -- ligo get-scope contract --format=json --with-types
 -- ```
 parseLigoTypesFor
-  :: FilePath
+  :: FilePath -- ^ Ligo output file path
-  -> Text
+  -> Text -- ^ Declaration name
   -> IO [(Text, LigoTypeFull)]
 parseLigoTypesFor contractPath name = do
   output <- C8.readFile contractPath
@@ -136,13 +184,15 @@ parseLigoTypesFor contractPath name = do
         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
+-- Execute ligo binary itself
+
+-- | Get raw aeson value for ligo scopes.
+getLigoScopesRaw
   :: LigoClientEnv
   -> FilePath
-  -> Text
+  -> IO Value
-  -> IO [(Text, LigoTypeFull)]
+getLigoScopesRaw env contractPath = do
-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)
@@ -150,9 +200,33 @@ getLigoTypesFor env contractPath name = do
       let variables = scopes ^? key "definitions" . key "variables"
       case variables of
         Nothing -> throwM $ VariableExtractError scopes
-        Just variables' -> return $ extractLigoTypesFrom name variables'
+        Just variables' -> return variables'
 
--- | Extract a list of types in scopes from aeson @Value@ for some specific declaration.
+-- | Extract scoped decls from ligo call.
+getLigoScopedDecls
+  :: LigoClientEnv
+  -> FilePath
+  -> IO (HM.HashMap Text ScopedDecl)
+getLigoScopedDecls env contractPath = do
+  scopes <- getLigoScopesRaw env contractPath
+  let interpreted =
+        scopes
+          ^@.. members
+            . (_JSON :: Prism' Value LigoScope)
+          ^. to HM.fromList
+  return $ toScopedDecl <$> interpreted
+
+-- | Get scopes from ligo compiler and extract a list of types associated with some specific variable.
+getLigoTypesFor
+  :: LigoClientEnv -- ^ Client environment
+  -> FilePath -- ^ Contract path
+  -> Text -- ^ Declaration name
+  -> IO (HM.HashMap Text LigoTypeFull)
+getLigoTypesFor env contractPath name = do
+  scopes <- getLigoScopesRaw env contractPath
+  return $ HM.fromList $ extractLigoTypesFrom name scopes
+
+-- | Extract a list of types in scopes from aeson @Value@ for some specific declaration under "name" field.
 extractLigoTypesFrom :: Text -> Value -> [(Text, LigoTypeFull)]
 extractLigoTypesFrom name context =
   let current =

tools/lsp/squirrel/src/Cli/Json.hs

@@ -1,13 +1,16 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric, RecordWildCards #-}
-{-# LANGUAGE RecordWildCards #-}
 
 -- | The definition of type as is represented in ligo JSON output
 module Cli.Json
-  ( LigoTypeFull (..)
+  ( LigoScope (..)
+  , LigoTypeFull (..)
   , LigoTypeContent (..)
   , LigoTypeContentInner (..)
   , LigoRecordField (..)
-  , LigoLocation (..)
+  , LigoRange (..)
+  , convertLigoRange
+  , toScopedDecl
+  , prepareField
   )
 where
 
@@ -15,28 +18,41 @@ import Data.Aeson
 import Data.Char (isUpper, toLower)
 import Data.Foldable (asum, toList)
 import qualified Data.HashMap.Strict as HM
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import GHC.Generics
 
+import AST.Scope
+import Range
+
 ----------------------------------------------------------------------------
 -- Types
 ----------------------------------------------------------------------------
 
+data LigoScope = LigoScope
+  { _lsName :: Text
+  , _lsRange :: LigoRange
+  , _lsBodyRange :: LigoRange
+  , _lsT :: LigoTypeFull
+  , _lsReferences :: Value
+  }
+  deriving stock (Generic, Show)
+
 -- | Whole ligo type.
 -- ```
 -- { "t" : LigoTypeFull }
 -- ```
 data LigoTypeFull = LigoTypeFull
   { -- | Location of the definition.
-    ltLocation :: LigoLocation
+    _ltLocation :: LigoRange
   , -- | *Some* meta constructors (e.g. `Some`).
-    ltTypeMeta :: Value
+    _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]
+    _ltTypeContent :: [LigoTypeContent]
   }
   deriving stock (Generic, Show)
 
@@ -45,8 +61,8 @@ data LigoTypeFull = LigoTypeFull
 -- { "type_content": LigoTypeContent }
 -- ```
 data LigoTypeContent = LigoTypeContent
-  { ltcName :: Text
+  { _ltcName :: Text
-  , ltcContentInner :: LigoTypeContentInner
+  , _ltcContentInner :: LigoTypeContentInner
   }
   deriving stock (Generic, Show)
 
@@ -57,15 +73,15 @@ data LigoTypeContent = LigoTypeContent
 data LigoTypeContentInner
   = -- | Type call represented by the list of arguments and its constructor.
     LTCConst
-      { ltciArguments :: [Text]
+      { _ltciArguments :: [Text]
-      , ltciTypeConst :: Value
+      , _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
+      { _ltciType2 :: LigoTypeFull
-      , ltcType1 :: LigoTypeFull
+      , _ltciType1 :: LigoTypeFull
       }
   deriving stock (Generic, Show)
 
@@ -76,27 +92,27 @@ data LigoTypeContentInner
 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
+    _lrfDeclPos :: Int
   , -- | How the value is represented in michelson, currently ignored
     -- during parsing.
-    lrfMichelsonAnnotation :: Value
+    _lrfMichelsonAnnotation :: Value
   , -- | The type itself.
-    lrfAssociatedType :: LigoTypeFull
+    _lrfAssociatedType :: LigoTypeFull
   }
   deriving stock (Generic, Show)
 
 -- | Location of type definition.
 -- ```
--- { "location": LigoLocation }
+-- { "location": LigoRange }
 -- ```
-data LigoLocation
+data LigoRange
   = Virtual Text
-  | LigoLocation
+  | LigoRange
-      { llFile :: FilePath
+      { _lrFile :: FilePath
-      , llFromRow :: Int
+      , _lrFromRow :: Int
-      , llFromCol :: Int
+      , _lrFromCol :: Int
-      , llToRow :: Int
+      , _lrToRow :: Int
-      , llToCol :: Int
+      , _lrToCol :: Int
       }
   deriving stock (Generic, Show)
 
@@ -104,20 +120,26 @@ data LigoLocation
 -- Instances
 ----------------------------------------------------------------------------
 
+instance FromJSON LigoScope where
+  parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = prepareField 2}
+
+instance ToJSON LigoScope where
+  toJSON = genericToJSON defaultOptions {fieldLabelModifier = prepareField 2}
+
 -- 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"
+    _ltLocation <- o .: "location"
     type_content <- o .: "type_content"
-    ltTypeContent <-
+    _ltTypeContent <-
       withArray "type_content" (mapM proceed . group 2 . toList) type_content
-    ltTypeMeta <- o .: "type_meta"
+    _ltTypeMeta <- o .: "type_meta"
     return $ LigoTypeFull {..}
     where
       proceed [name, value] = do
-        ltcName <- parseJSON @Text name
+        _ltcName <- parseJSON @Text name
-        ltcContentInner <- parseJSON @LigoTypeContentInner value
+        _ltcContentInner <- parseJSON @LigoTypeContentInner value
         return $ LigoTypeContent {..}
       proceed _ = error "number of type content elements is not even and cannot be grouped"
 
@@ -147,20 +169,20 @@ instance FromJSON LigoRecordField where
 instance ToJSON LigoRecordField where
   toJSON = genericToJSON defaultOptions {fieldLabelModifier = prepareField 3}
 
-instance FromJSON LigoLocation where
+instance FromJSON LigoRange where
   parseJSON = withObject "location" $ \o ->
     asum
       [ Virtual <$> o .: "virtual"
       , do
-          llFile <- o .: "file"
+          _lrFile <- o .: "file"
-          llFromRow <- o .: "from_row"
+          _lrFromRow <- o .: "from_row"
-          llFromCol <- o .: "from_col"
+          _lrFromCol <- o .: "from_col"
-          llToRow <- o .: "to_row"
+          _lrToRow <- o .: "to_row"
-          llToCol <- o .: "to_col"
+          _lrToCol <- o .: "to_col"
-          return $ LigoLocation {..}
+          return $ LigoRange {..}
       ]
 
-instance ToJSON LigoLocation where
+instance ToJSON LigoRange where
   toJSON = genericToJSON defaultOptions {fieldLabelModifier = prepareField 2}
 
 ----------------------------------------------------------------------------
@@ -169,10 +191,10 @@ instance ToJSON LigoLocation where
 
 -- | Helper function that converts qualified field to its JSON counterpart.
 --
--- >>> prepareField 2 "llFooBar"
+-- >>> prepareField 2 "__llFooBar"
 -- "foo_bar"
 prepareField :: Int -> String -> String
-prepareField dropAmount = Prelude.drop (dropAmount + 1) . concatMap process
+prepareField dropAmount = Prelude.drop (dropAmount + 2) . concatMap process
   where
     process c
       | isUpper c = "_" <> [toLower c]
@@ -187,3 +209,34 @@ group _ [] = []
 group n l
   | n > 0 = (take n l) : (group n (drop n l))
   | otherwise = error "Negative or zero n"
+
+-- | Converts ligo ranges to our internal ones.
+-- >>> convertLigoRange (LigoRange "test.ligo" 1 2 3 4)
+-- [test.ligo:1:2-3:4]
+convertLigoRange :: LigoRange -> Maybe Range
+convertLigoRange (Virtual _) = Nothing
+convertLigoRange LigoRange {..} =
+  Just
+    Range
+      { rStart = (_lrFromRow, _lrFromCol, 0)
+      , rFinish = (_lrToRow, _lrToCol, 0)
+      , rFile = _lrFile
+      }
+
+-- | Converts ligo scope to our internal one.
+-- TODO: convert `LigoTypeFull` to `LIGO ()`
+toScopedDecl :: LigoScope -> ScopedDecl
+toScopedDecl
+  LigoScope
+    { _lsName = _sdName
+    , _lsRange = (fromMaybe (error "no origin range") . convertLigoRange -> _sdOrigin)
+    , _lsBodyRange = (convertLigoRange -> _sdBody)
+    } =
+    ScopedDecl
+      { _sdName
+      , _sdOrigin
+      , _sdBody
+      , _sdType = Nothing
+      , _sdRefs = []
+      , _sdDoc = []
+      }