balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix AST.Scope

Browse Source
This commit is contained in:
Kirill Andreev 2020-08-04 17:31:55 +04:00
parent 31274e1507
commit 08a0eb55d1
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
6 changed files with 117 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
tools/lsp/squirrel/src/AST/Find.hs
View File

@ -17,7 +17,7 @@ import AST.Scope
import Product
import Range
-- import Debug.Trace
import Debug.Trace
type CanSearch xs =
( Contains [ScopedDecl] xs
@ -25,6 +25,7 @@ type CanSearch xs =
, Contains (Maybe Category) xs
, Contains [Text] xs
, Pretty (Product xs)
, Modifies (Product xs)
, Eq (Product xs)
)

116
tools/lsp/squirrel/src/AST/Parser.hs
View File

@ -72,15 +72,14 @@ source
recognise :: RawTree -> ParserM (LIGO Info)
recognise = descent (\_ -> error . show . pp) $ map usingScope
[ -- Contract
Descent
[ boilerplate \case
Descent do
boilerplate \case
"Start" -> RawContract <$> fields "declaration"
_ -> fallthrough
]
-- Expr
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"let_expr" -> Let <$> field "locals" <*> field "body"
"fun_call" -> Apply <$> field "f" <*> field "arguments"
"par_call" -> Apply <$> field "f" <*> field "arguments"
@ -118,44 +117,39 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
"map_remove" -> SetRemove <$> field "key" <*> field "container"
"update_record" -> RecordUpd <$> field "record" <*> fields "assignment"
_ -> fallthrough
]
-- Pattern
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"user_constr_pattern" -> IsConstr <$> field "constr" <*> fieldOpt "arguments"
"tuple_pattern" -> IsTuple <$> fields "element"
"nil" -> return $ IsList []
"list_pattern" -> IsList <$> fields "element"
"cons_pattern" -> IsCons <$> field "head" <*> field "tail"
_ -> fallthrough
]
-- Alt
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"case_clause_expr" -> Alt <$> field "pattern" <*> field "body"
"case_clause_instr" -> Alt <$> field "pattern" <*> field "body"
_ -> fallthrough
]
-- FieldAssignment
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"field_assignment" -> FieldAssignment <$> field "name" <*> field "_rhs"
"field_path_assignment" -> FieldAssignment <$> field "lhs" <*> field "_rhs"
_ -> fallthrough
]
-- MapBinding
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"binding" -> MapBinding <$> field "key" <*> field "value"
_ -> fallthrough
]
, Descent
[ boilerplate' \case
, Descent do
boilerplate' \case
("negate", op) -> return $ Op op
("adder", op) -> return $ Op op
("multiplier", op) -> return $ Op op
@ -163,72 +157,64 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
("^", _) -> return $ Op "^"
("#", _) -> return $ Op "#"
_ -> fallthrough
]
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"data_projection" -> QualifiedName <$> field "struct" <*> fields "index"
"map_lookup" -> QualifiedName <$> field "container" <*> fields "index"
"module_field" -> QualifiedName <$> field "module" <*> fields "method"
_ -> fallthrough
]
-- Literal
, Descent
[ boilerplate' \case
, Descent do
boilerplate' \case
("Int", i) -> return $ Int i
("Nat", i) -> return $ Nat i
("Bytes", i) -> return $ Bytes i
("String", i) -> return $ String i
("Tez", i) -> return $ Tez i
_ -> fallthrough
]
-- Declaration
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"fun_decl" -> Function <$> (isJust <$> fieldOpt "recursive") <*> field "name" <*> field "parameters" <*> field "type" <*> field "body"
"const_decl" -> Const <$> field "name" <*> field "type" <*> field "value"
"var_decl" -> Var <$> field "name" <*> field "type" <*> field "value"
"type_decl" -> TypeDecl <$> field "typeName" <*> field "typeValue"
"include" -> Include <$> field "filename"
_ -> fallthrough
]
-- Parameters
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"parameters" -> Parameters <$> fields "parameter"
_ -> fallthrough
]
-- VarDecl
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"param_decl" -> Decl <$> field "access" <*> field "name" <*> field "type"
_ -> fallthrough
]
-- Mutable
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"const" -> return Immutable
"var" -> return Mutable
_ -> fallthrough
]
-- Name
, Descent
[ boilerplate' \case
, Descent do
boilerplate' \case
("Name", n) -> return $ Name n
("and", _) -> return $ Name "and"
("or", _) -> return $ Name "or"
_ -> fallthrough
]
-- Type
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"fun_type" -> TArrow <$> field "domain" <*> field "codomain"
"cartesian" -> TProduct <$> fields "element"
"invokeBinary" -> TApply <$> field "typeConstr" <*> field "arguments"
@ -239,25 +225,22 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
"michelsonTypeOr" -> TOr <$> field "left_type" <*> field "left_type_name" <*> field "right_type" <*> field "right_type_name"
"michelsonTypeAnd" -> TAnd <$> field "left_type" <*> field "left_type_name" <*> field "right_type" <*> field "right_type_name"
_ -> fallthrough
]
-- Variant
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"variant" -> Variant <$> field "constructor" <*> fieldOpt "arguments"
_ -> fallthrough
]
-- TField
, Descent
[ boilerplate \case
, Descent do
boilerplate \case
"field_decl" -> TField <$> field "fieldName" <*> field "fieldType"
_ -> fallthrough
]
-- TypeName
, Descent
[ boilerplate' \case
, Descent do
boilerplate' \case
("TypeName", name) -> return $ TypeName name
("list", _) -> return $ TypeName "list"
("big_map", _) -> return $ TypeName "big_map"
@ -266,11 +249,10 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
("option", _) -> return $ TypeName "option"
("contract", _) -> return $ TypeName "contract"
_ -> fallthrough
]
-- Ctor
, Descent
[ boilerplate' \case
, Descent do
boilerplate' \case
("Name_Capital", name) -> return $ Ctor name
("Some", _) -> return $ Ctor "Some"
("Some_pattern", _) -> return $ Ctor "Some"
@ -280,27 +262,23 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
("Unit", _) -> return $ Ctor "Unit"
("constr", n) -> return $ Ctor n
_ -> fallthrough
]
-- FieldName
, Descent
[ boilerplate' \case
, Descent do
boilerplate' \case
("FieldName", name) -> return $ FieldName name
_ -> fallthrough
]
-- Err
, Descent
[ \(r :> _, ParseTree _ _ text) -> do
, Descent do
\(r :> _, ParseTree _ _ text) -> do
withComments do
return $ Just (r :> N :> Nil, Err text)
]
return (r :> N :> Nil, Err text)
, Descent
[ \case
, Descent do
\case
(r :> _, ParseTree "ERROR" _ text) -> do
return $ Just ([] :> r :> Y :> Nil, Err text)
return ([] :> r :> Y :> Nil, Err text)
_ -> return Nothing
]
_ -> fallthrough
]

75
tools/lsp/squirrel/src/AST/Scope.hs
View File

@ -16,6 +16,8 @@ module AST.Scope
import Control.Arrow (first, second)
import Control.Monad.State
import Control.Monad.Identity
import Control.Monad.Catch
import Control.Monad.Catch.Pure
import qualified Data.List as List
import Data.Map (Map)
@ -23,6 +25,7 @@ import qualified Data.Map as Map
import Data.Maybe (listToMaybe)
import Data.Sum (Element, Apply, Sum)
import Data.Text (Text)
import Data.Either (fromRight)
import Duplo.Lattice
import Duplo.Pretty
@ -38,7 +41,7 @@ import Range
import Debug.Trace
type CollectM = State (Product [FullEnv, [Range]])
type CollectM = StateT (Product [FullEnv, [Range]]) Catch
type FullEnv = Product ["vars" := Env, "types" := Env]
type Env = Map Range [ScopedDecl]
@ -106,19 +109,20 @@ instance Modifies (Product '[[ScopedDecl], Maybe Category, [Text], Range, a]) wh
$$ d
addLocalScopes
:: (Contains Range xs, Eq (Product xs))
:: forall xs
. (Contains Range xs, Eq (Product xs))
=> LIGO (Product xs)
-> LIGO (Product ([ScopedDecl] : Maybe Category : xs))
addLocalScopes tree =
fmap (\xs -> fullEnvAt envWithREfs (getRange xs) :> xs) tree1
where
tree0 = runIdentity $ unLetRec tree
tree0 = either (error . show) id $ runCatch $ unLetRec tree
tree1 = addNameCategories tree0
envWithREfs = getEnvTree tree0
unLetRec
:: forall xs m
. ( Monad m
. ( MonadCatch m
, Contains Range xs
, Eq (Product xs)
)
@ -126,10 +130,9 @@ unLetRec
-> m (LIGO (Product xs))
unLetRec = descent leaveBe
[ Descent
[ \case
(r, Let (layer -> Just (Seq xs)) b) -> return $ convert (getElem r) b xs
_ -> return Nothing
]
\case
(r, Let (layer -> Just (Seq xs)) b) -> maybe (throwM HandlerFailed) return $ convert (getElem r) b xs
_ -> fallthrough
]
where
convert :: Range -> LIGO (Product xs) -> [LIGO (Product xs)] -> Maybe (Product xs, Expr (LIGO (Product xs)))
@ -145,19 +148,17 @@ addNameCategories
:: (Contains Range xs, Eq (Product xs))
=> LIGO (Product xs)
-> LIGO (Product (Maybe Category : xs))
addNameCategories tree = flip evalState emptyEnv do
addNameCategories tree = evalCollectM do
descent (changeInfo (Nothing :>))
[ Descent
[ \(r, Name t) -> do
-- modify $ getRange r `addRef` (Variable, t)
return $ Just $ (Just Variable :> r, Name t)
]
\(r, Name t) -> do
modify $ modElem $ getRange r `addRef` (Variable, t)
return $ (Just Variable :> r, Name t)
, Descent
[ \(r, TypeName t) -> do
-- modify $ getRange r `addRef` (Type, t)
return $ Just $ (Just Type :> r, TypeName t)
]
\(r, TypeName t) -> do
modify $ modElem $ getRange r `addRef` (Type, t)
return $ (Just Type :> r, TypeName t)
]
tree
@ -175,19 +176,15 @@ getEnvTree
-> FullEnv
getEnvTree tree = envWithREfs
where
envWithREfs = flip execState env do
envWithREfs = execCollectM' env do
descent leaveBe
[ Descent
[ \(r, Name t) -> do
modify $ getRange r `addRef` (Variable, t)
return $ Just (r, Name t)
]
[ Descent \(r, Name t) -> do
modify $ modElem $ getRange r `addRef` (Variable, t)
return (r, Name t)
, Descent
[ \(r, TypeName t) -> do
modify $ getRange r `addRef` (Type, t)
return $ Just (r, TypeName t)
]
, Descent \(r, TypeName t) -> do
modify $ modElem $ getRange r `addRef` (Type, t)
return (r, TypeName t)
]
tree
@ -269,7 +266,27 @@ leave = modify $ modElem @[Range] tail
-- | Run the computation with scope starting from empty scope.
execCollectM :: CollectM a -> FullEnv
execCollectM action = getElem $ execState action $ emptyEnv :> [] :> Nil
execCollectM = execCollectM' emptyEnv
execCollectM' :: FullEnv -> CollectM a -> FullEnv
execCollectM' env action
= getElem
$ either (error . show) id
$ runCatch
$ execStateT action
$ env :> [] :> Nil
-- | Run the computation with scope starting from empty scope.
evalCollectM :: CollectM a -> a
evalCollectM = evalCollectM' emptyEnv
-- | Run the computation with scope starting from empty scope.
evalCollectM' :: FullEnv -> CollectM a -> a
evalCollectM' env action
= either (error . show) id
$ runCatch
$ evalStateT action
$ env :> [] :> Nil
-- | Search for a name inside a local scope.
lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl

47
tools/lsp/squirrel/src/Parser.hs
View File

@ -30,19 +30,10 @@ import Debug.Trace
-}
runParserM :: ParserM a -> IO (a, [Msg])
runParserM p = (\(a, _, errs) -> (a, errs)) <$> runRWST p () ([], [])
runParserM1 :: [RawTree] -> ParserM1 a -> ParserM (Maybe a)
runParserM1 cs p = do
s <- get
(a, s1, w) <- lift $ runRWST (runMaybeT p) cs s
tell w
put s1
return a
runParserM p = (\(a, _, errs) -> (a, errs)) <$> runRWST p [] ([], [])
type Msg = (Range, Err Text ())
type ParserM = RWST () [Msg] ([Text], [Text]) IO
type ParserM1 = MaybeT (RWST [RawTree] [Msg] ([Text], [Text]) IO)
type ParserM = RWST [RawTree] [Msg] ([Text], [Text]) IO
data Failure = Failure String
deriving stock (Show)
@ -87,12 +78,12 @@ allErrors = map getBody . filter isUnnamedError
getBody (gist -> f) = ptSource f
field :: Text -> ParserM1 RawTree
field :: Text -> ParserM RawTree
field name =
fieldOpt name
>>= maybe (throwM $ Failure [i|Cannot find field #{name}|]) return
fieldOpt :: Text -> ParserM1 (Maybe RawTree)
fieldOpt :: Text -> ParserM (Maybe RawTree)
fieldOpt name = ask >>= go
where
go (tree@(extract -> _ :> n :> _) : rest)
@ -101,7 +92,7 @@ fieldOpt name = ask >>= go
go [] = return Nothing
fields :: Text -> ParserM1 [RawTree]
fields :: Text -> ParserM [RawTree]
fields name = ask >>= go
where
go (tree@(extract -> _ :> n :> _) : rest) =
@ -131,33 +122,29 @@ ascribeComms comms
ascribeRange r Y = (pp r $$)
ascribeRange _ _ = id
withComments :: ParserM (Maybe (Product xs, a)) -> ParserM (Maybe (Product ([Text] : xs), a))
withComments :: ParserM (Product xs, a) -> ParserM (Product ([Text] : xs), a)
withComments act = do
comms <- grabComments
res <- act
return $ fmap (first (comms :>)) res
return $ first (comms :>) res
boilerplate
:: (Text -> ParserM1 (f RawTree))
:: (Text -> ParserM (f RawTree))
-> (RawInfo, ParseTree RawTree)
-> ParserM (Maybe (Info, f RawTree))
-> ParserM (Info, f RawTree)
boilerplate f (r :> _, ParseTree ty cs _) = do
withComments do
mbf <- runParserM1 cs $ f ty
return do
f <- mbf
return $ (r :> N :> Nil, f)
f <- local (const cs) $ f ty
return $ (r :> N :> Nil, f)
boilerplate'
:: ((Text, Text) -> ParserM1 (f RawTree))
:: ((Text, Text) -> ParserM (f RawTree))
-> (RawInfo, ParseTree RawTree)
-> ParserM (Maybe (Info, f RawTree))
-> ParserM (Info, f RawTree)
boilerplate' f (r :> _, ParseTree ty cs src) = do
withComments do
mbf <- runParserM1 cs $ f (ty, src)
return do
f <- mbf
return $ (r :> N :> Nil, f)
f <- local (const cs) $ f (ty, src)
return $ (r :> N :> Nil, f)
fallthrough :: MonadFail m => m a
fallthrough = fail ""
fallthrough :: MonadThrow m => m a
fallthrough = throwM HandlerFailed

58
tools/lsp/squirrel/stack.yaml
View File

@ -3,37 +3,11 @@
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-15.10
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# subdirs:
# - auto-update
# - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
#
extra-deps:
- tree-sitter-0.9.0.0@sha256:4fd054b0a9651df9335c5fa0ffed723924dc4dcf7f2521c031323088ca719b05,3411
- semantic-source-0.0.2.0@sha256:eac962ed1150d8647e703bc78369ecc4c1912db018e111f4ead8a62ae1a85542,2368
@ -41,35 +15,7 @@ extra-deps:
- semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909
- fastsum-0.1.1.1
- git: https://github.com/serokell/duplo.git
commit: e6e2e382bb381ce629e71ab3d08274396e686ba3
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
commit: 0cc243e90bc497989ec48417a6b5a5ce6a01759f
# Override default flag values for local packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=2.1"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor
nix:
packages: [zlib]

6
tools/lsp/squirrel/stack.yaml.lock
View File

@ -45,11 +45,11 @@ packages:
git: https://github.com/serokell/duplo.git
pantry-tree:
size: 557
sha256: bdd68d3e171c6a2311ca101cc654a5cca984a1e8ce745e928287a40fa8f5a0ff
commit: e6e2e382bb381ce629e71ab3d08274396e686ba3
sha256: e8618a84baa4c24a1cabc47008cc12bbb7bd52b6fd8acaff6c4871201509c2ac
commit: 0cc243e90bc497989ec48417a6b5a5ce6a01759f
original:
git: https://github.com/serokell/duplo.git
commit: e6e2e382bb381ce629e71ab3d08274396e686ba3
commit: 0cc243e90bc497989ec48417a6b5a5ce6a01759f
snapshots:
- completed:
size: 493124