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

Restore AST.Scope instances and part of the machinery

Browse Source
This commit is contained in:
Kirill Andreev 2020-07-27 23:27:50 +04:00
parent b5e5bc25a1
commit 226b7264aa
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
5 changed files with 217 additions and 221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -70,7 +70,7 @@ source
>>= print . pp >>= print . pp
recognise :: RawTree -> ParserM (LIGO Info) recognise :: RawTree -> ParserM (LIGO Info)
recognise = descent (error . show . pp) $ map usingScope recognise = descent (error . show . pp . fst) $ map usingScope
[ -- Contract [ -- Contract
Descent Descent
[ boilerplate \case [ boilerplate \case

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

@ -34,52 +34,64 @@ import AST.Types
import Product import Product
import Range import Range
-- import Debug.Trace import Debug.Trace
-- type CollectM = State (Product [FullEnv, [Range]]) type CollectM = State (Product [FullEnv, [Range]])
-- type FullEnv = Product ["vars" := Env, "types" := Env] type FullEnv = Product ["vars" := Env, "types" := Env]
-- type Env = Map Range [ScopedDecl] type Env = Map Range [ScopedDecl]
-- data Category = Variable | Type data Category = Variable | Type
-- -- | The type/value declaration. -- | The type/value declaration.
-- data ScopedDecl = ScopedDecl data ScopedDecl = ScopedDecl
-- { _sdName :: Pascal () { _sdName :: LIGO ()
-- , _sdOrigin :: Range , _sdOrigin :: Range
-- , _sdBody :: Maybe Range , _sdBody :: Maybe Range
-- , _sdType :: Maybe (Either (Pascal ()) Kind) , _sdType :: Maybe (Either (LIGO ()) Kind)
-- , _sdRefs :: [Range] , _sdRefs :: [Range]
-- } }
-- deriving Show via PP ScopedDecl deriving Show via PP ScopedDecl
-- -- | The kind. -- | The kind.
-- data Kind = Star data Kind = Star
-- deriving Show via PP Kind deriving Show via PP Kind
-- emptyEnv :: FullEnv instance {-# OVERLAPS #-} Pretty FullEnv where
-- emptyEnv pp = block . map aux . Map.toList . mergeFE
-- = Cons (Tag Map.empty) where
-- $ Cons (Tag Map.empty) aux (r, fe) =
-- Nil pp r `indent` block fe
-- with :: Category -> FullEnv -> (Env -> Env) -> FullEnv mergeFE fe = getTag @"vars" @Env fe Prelude.<> getTag @"types" fe
-- with Variable env f = modTag @"vars" f env
-- with Type env f = modTag @"types" f env
-- ofCategory :: Category -> ScopedDecl -> Bool instance Pretty ScopedDecl where
-- ofCategory Variable ScopedDecl { _sdType = Just (Right Star) } = False pp (ScopedDecl n o _ t refs) = color 3 (pp n) <+> pp o <+> ":" <+> color 4 (maybe "?" (either pp pp) t) <+> "=" <+> pp refs
-- ofCategory Variable _ = True
-- ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True instance Pretty Kind where
-- ofCategory _ _ = False pp _ = "TYPE"
instance Pretty Category where
pp Variable = "Variable"
pp Type = "Type"
emptyEnv :: FullEnv
emptyEnv = Tag Map.empty :> Tag Map.empty :> Nil
with :: Category -> FullEnv -> (Env -> Env) -> FullEnv
with Variable env f = modTag @"vars" f env
with Type env f = modTag @"types" f env
ofCategory :: Category -> ScopedDecl -> Bool
ofCategory Variable ScopedDecl { _sdType = Just (Right Star) } = False
ofCategory Variable _ = True
ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True
ofCategory _ _ = False
-- -- | Calculate scopes and attach to all tree points declarations that are
-- -- visible there.
-- --
-- addLocalScopes -- addLocalScopes
-- :: Contains Range xs -- :: Contains Range xs
-- => Pascal (Product xs) -- => LIGO (Product xs)
-- -> Pascal (Product ([ScopedDecl] : Maybe Category : xs)) -- -> LIGO (Product ([ScopedDecl] : Maybe Category : xs))
-- addLocalScopes tree = -- addLocalScopes tree =
-- fmap (\xs -> Cons (fullEnvAt envWithREfs (getRange xs)) xs) tree1 -- fmap (\xs -> Cons (fullEnvAt envWithREfs (getRange xs)) xs) tree1
-- where -- where
@ -88,8 +100,8 @@ import Range
-- addNameCategories -- addNameCategories
-- :: Contains Range xs -- :: Contains Range xs
-- => Pascal (Product xs) -- => LIGO (Product xs)
-- -> Pascal (Product (Maybe Category : xs)) -- -> LIGO (Product (Maybe Category : xs))
-- addNameCategories tree = flip evalState emptyEnv do -- addNameCategories tree = flip evalState emptyEnv do
-- traverseMany -- traverseMany
-- [ Visit \r (Name t) -> do -- [ Visit \r (Name t) -> do
@ -104,7 +116,7 @@ import Range
-- tree -- tree
-- getEnvTree -- getEnvTree
-- :: ( Scoped CollectM (Sum fs) (Tree fs b) -- :: ( Apply (Scoped b CollectM (Tree fs b)) fs
-- , Apply Foldable fs -- , Apply Foldable fs
-- , Apply Functor fs -- , Apply Functor fs
-- , Apply Traversable fs -- , Apply Traversable fs
@ -117,128 +129,115 @@ import Range
-- getEnvTree tree = envWithREfs -- getEnvTree tree = envWithREfs
-- where -- where
-- envWithREfs = flip execState env do -- envWithREfs = flip execState env do
-- traverseMany -- descent return
-- [ Visit \r (Name t) -> do -- [ usingScope $ Descent
-- [ \(r, Name t) -> do
-- modify $ getRange r `addRef` (Variable, t) -- modify $ getRange r `addRef` (Variable, t)
-- return $ (r, Name t) -- return $ (r, Name t)
-- ]
-- , Visit \r (TypeName t) -> do -- , usingScope $ Descent
-- [ \(r, TypeName t) -> do
-- modify $ getRange r `addRef` (Type, t) -- modify $ getRange r `addRef` (Type, t)
-- return $ (r, TypeName t) -- return $ (r, TypeName t)
-- ] -- ]
-- id -- ]
-- tree -- tree
-- env -- env
-- = execCollectM -- = execCollectM
-- $ traverseTree pure tree -- $ traverseTree pure tree
-- fullEnvAt :: FullEnv -> Range -> [ScopedDecl] fullEnvAt :: FullEnv -> Range -> [ScopedDecl]
-- fullEnvAt fe r = envAt (getTag @"types" fe) r <> envAt (getTag @"vars" fe) r fullEnvAt fe r
= envAt (getTag @"types" fe) r
`mappend` envAt (getTag @"vars" fe) r
-- envAt :: Env -> Range -> [ScopedDecl] envAt :: Env -> Range -> [ScopedDecl]
-- envAt env pos = envAt env pos =
-- Map.elems scopes Map.elems scopes
-- where where
-- ranges = List.sortBy partOrder $ filter isCovering $ Map.keys env ranges = List.sortBy partOrder $ filter isCovering $ Map.keys env
-- scopes = Map.unions $ (map.foldMap) toScopeMap $ map (env Map.!) ranges scopes = Map.unions $ (map.foldMap) toScopeMap $ map (env Map.!) ranges
-- isCovering = (pos <?) isCovering = (pos `leq`)
-- toScopeMap sd@ScopedDecl {_sdName} = Map.singleton (ppToText _sdName) sd toScopeMap sd@ScopedDecl {_sdName} = Map.singleton (ppToText _sdName) sd
-- addRef :: Range -> (Category, Text) -> FullEnv -> FullEnv addRef :: Range -> (Category, Text) -> FullEnv -> FullEnv
-- addRef r (categ, n) env = addRef r (categ, n) env =
-- with categ env \slice -> with categ env \slice ->
-- Map.union Map.union
-- (go slice $ range slice) (go slice $ range slice)
-- slice slice
-- where where
-- go slice (r' : rest) = go slice (r' : rest) =
-- let decls = slice Map.! r' let decls = slice Map.! r'
-- in in
-- case updateOnly n r addRefToDecl decls of case updateOnly n r addRefToDecl decls of
-- (True, decls') -> Map.singleton r' decls' (True, decls') -> Map.singleton r' decls'
-- (False, decls') -> Map.insert r' decls' (go slice rest) (False, decls') -> Map.insert r' decls' (go slice rest)
-- go _ [] = Map.empty go _ [] = Map.empty
-- range slice range slice
-- = List.sortBy partOrder = List.sortBy partOrder
-- $ filter (r <?) $ filter (r `leq`)
-- $ Map.keys slice $ Map.keys slice
-- addRefToDecl sd = sd addRefToDecl sd = sd
-- { _sdRefs = r : _sdRefs sd { _sdRefs = r : _sdRefs sd
-- } }
-- updateOnly updateOnly
-- :: Text :: Text
-- -> Range -> Range
-- -> (ScopedDecl -> ScopedDecl) -> (ScopedDecl -> ScopedDecl)
-- -> [ScopedDecl] -> [ScopedDecl]
-- -> (Bool, [ScopedDecl]) -> (Bool, [ScopedDecl])
-- updateOnly name r f = go updateOnly name r f = go
-- where where
-- go = \case go = \case
-- d : ds d : ds
-- | ppToText (_sdName d) == name -> | ppToText (_sdName d) == name ->
-- if r == _sdOrigin d if r == _sdOrigin d
-- then (True, d : ds) then (True, d : ds)
-- else (True, f d : ds) else (True, f d : ds)
-- | otherwise -> second (d :) (go ds) | otherwise -> second (d :) (go ds)
-- [] -> (False, []) [] -> (False, [])
-- enter :: Range -> CollectM () enter :: Contains Range xs => Product xs -> CollectM ()
-- enter r = do enter r = do
-- modify $ modElem (r :) modify $ modElem (getElem @Range r :)
-- define :: Category -> ScopedDecl -> CollectM () define :: Category -> ScopedDecl -> CollectM ()
-- define categ sd = do define categ sd = do
-- r <- gets (head . getElem @[Range]) r <- gets (head . getElem @[Range])
-- modify modify
-- $ modElem @FullEnv \env -> $ modElem @FullEnv \env ->
-- with categ env with categ env
-- $ Map.insertWith (++) r [sd] $ Map.insertWith (++) r [sd]
-- leave :: CollectM () leave :: CollectM ()
-- leave = modify $ modElem @[Range] tail leave = modify $ modElem @[Range] tail
-- -- | Run the computation with scope starting from empty scope. -- | Run the computation with scope starting from empty scope.
-- execCollectM :: CollectM a -> FullEnv execCollectM :: CollectM a -> FullEnv
-- execCollectM action = getElem $ execState action $ Cons emptyEnv (Cons [] Nil) execCollectM action = getElem $ execState action $ emptyEnv :> [] :> Nil
-- instance {-# OVERLAPS #-} Pretty FullEnv where -- | Search for a name inside a local scope.
-- pp = block . map aux . Map.toList . mergeFE lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl
-- where lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName)
-- aux (r, fe) =
-- pp r `indent` block fe
-- mergeFE fe = getTag @"vars" @Env fe <> getTag @"types" fe -- | Add a type declaration to the current scope.
defType :: HasRange a => LIGO a -> Kind -> LIGO a -> CollectM ()
-- instance Pretty ScopedDecl where defType name kind body = do
-- pp (ScopedDecl n o _ t refs) = color 3 (pp n) <+> pp o <+> ":" <+> color 4 (maybe "?" (either pp pp) t) <+> "=" <+> pp refs define Type
$ ScopedDecl
-- instance Pretty Kind where (void name)
-- pp _ = "TYPE" (getRange $ extract name)
(Just $ getRange $ extract body)
-- instance Pretty Category where (Just (Right kind))
-- pp Variable = "Variable" []
-- pp Type = "Type"
-- -- | Search for a name inside a local scope.
-- lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl
-- lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName)
-- -- | Add a type declaration to the current scope.
-- defType :: HasRange a => Pascal a -> Kind -> Pascal a -> CollectM ()
-- defType name kind body = do
-- define Type
-- $ ScopedDecl
-- (void name)
-- (getRange $ infoOf name)
-- (Just $ getRange $ infoOf body)
-- (Just (Right kind))
-- []
-- -- observe :: Pretty i => Pretty res => Text -> i -> res -> res -- -- observe :: Pretty i => Pretty res => Text -> i -> res -> res
-- -- observe msg i res -- -- observe msg i res
@ -246,96 +245,93 @@ import Range
-- -- $ traceShow (pp msg, "OUTPUT", pp res) -- -- $ traceShow (pp msg, "OUTPUT", pp res)
-- -- $ res -- -- $ res
-- -- | Add a value declaration to the current scope. -- | Add a value declaration to the current scope.
-- def def
-- :: HasRange a :: HasRange a
-- => Pascal a => LIGO a
-- -> Maybe (Pascal a) -> Maybe (LIGO a)
-- -> Maybe (Pascal a) -> Maybe (LIGO a)
-- -> CollectM () -> CollectM ()
-- def name ty body = do def name ty body = do
-- define Variable define Variable
-- $ ScopedDecl $ ScopedDecl
-- (void name) (void name)
-- (getRange $ infoOf name) (getRange $ extract name)
-- ((getRange . infoOf) <$> body) ((getRange . extract) <$> body)
-- ((Left . void) <$> ty) ((Left . void) <$> ty)
-- [] []
-- instance UpdateOver CollectM Contract (Pascal a) where instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Contract where
-- before r _ = enter r before r _ = enter r
-- after _ _ = skip after _ _ = skip
-- instance HasRange a => UpdateOver CollectM Declaration (Pascal a) where instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Binding where
-- before _ = \case before r = \case
-- TypeDecl ty body -> defType ty Star body Function recur name _args ty body -> do
-- _ -> skip when recur do
def name (Just ty) (Just body)
enter r
-- instance HasRange a => UpdateOver CollectM Binding (Pascal a) where TypeDecl ty body -> defType ty Star body
-- before r = \case _ -> enter r
-- Function recur name _args ty body -> do
-- when recur do
-- def name (Just ty) (Just body)
-- enter r
-- _ -> enter r after _ = \case
Irrefutable name body -> do leave; def name Nothing (Just body)
Var name ty body -> do leave; def name (Just ty) (Just body)
Const name ty body -> do leave; def name (Just ty) (Just body)
Function recur name _args ty body -> do
leave
unless recur do
def name (Just ty) (Just body)
_ -> skip
-- after _ = \case instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) VarDecl where
-- Irrefutable name body -> do leave; def name Nothing (Just body) after _ (Decl _ name ty) = def name (Just ty) Nothing
-- Var name ty body -> do leave; def name (Just ty) (Just body)
-- Const name ty body -> do leave; def name (Just ty) (Just body)
-- Function recur name _args ty body -> do
-- leave
-- unless recur do
-- def name (Just ty) (Just body)
-- instance HasRange a => UpdateOver CollectM VarDecl (Pascal a) where instance Scoped a CollectM (LIGO a) Mutable
-- after _ (Decl _ name ty) = def name (Just ty) Nothing instance Scoped a CollectM (LIGO a) Type
instance Scoped a CollectM (LIGO a) Variant
instance Scoped a CollectM (LIGO a) TField
-- instance UpdateOver CollectM Mutable (Pascal a) instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Expr where
-- instance UpdateOver CollectM Type (Pascal a) before r = \case
-- instance UpdateOver CollectM Variant (Pascal a) Let {} -> enter r
-- instance UpdateOver CollectM TField (Pascal a) Lambda {} -> enter r
ForLoop k _ _ _ _ -> do
enter r
def k Nothing Nothing
-- instance HasRange a => UpdateOver CollectM Expr (Pascal a) where ForBox k mv _ _ _ -> do
-- before r = \case enter r
-- Let {} -> enter r def k Nothing Nothing
-- Lambda {} -> enter r maybe skip (\v -> def v Nothing Nothing) mv
-- ForLoop k _ _ _ -> do
-- enter r
-- def k Nothing Nothing
-- ForBox k mv _ _ _ -> do _ -> skip
-- enter r
-- def k Nothing Nothing
-- maybe skip (\v -> def v Nothing Nothing) mv
-- _ -> skip after _ = \case
Let {} -> leave
Lambda {} -> leave
ForLoop {} -> leave
ForBox {} -> leave
_ -> skip
-- after _ = \case instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Alt where
-- Let {} -> leave before r _ = enter r
-- Lambda {} -> leave after _ _ = leave
-- ForLoop {} -> leave
-- ForBox {} -> leave
-- _ -> skip
-- instance HasRange a => UpdateOver CollectM Alt (Pascal a) where instance Scoped a CollectM (LIGO a) LHS
-- before r _ = enter r instance Scoped a CollectM (LIGO a) MapBinding
-- after _ _ = leave instance Scoped a CollectM (LIGO a) Assignment
instance Scoped a CollectM (LIGO a) FieldAssignment
instance Scoped a CollectM (LIGO a) Constant
-- instance UpdateOver CollectM LHS (Pascal a) instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Pattern where
-- instance UpdateOver CollectM MapBinding (Pascal a) before _ = \case
-- instance UpdateOver CollectM Assignment (Pascal a) IsVar n -> def n Nothing Nothing
-- instance UpdateOver CollectM FieldAssignment (Pascal a) _ -> skip
-- instance UpdateOver CollectM Constant (Pascal a)
-- instance HasRange a => UpdateOver CollectM Pattern (Pascal a) where instance Scoped a CollectM (LIGO a) QualifiedName
-- before _ = \case instance Scoped a CollectM (LIGO a) Path
-- IsVar n -> def n Nothing Nothing instance Scoped a CollectM (LIGO a) Name
-- _ -> skip instance Scoped a CollectM (LIGO a) TypeName
instance Scoped a CollectM (LIGO a) FieldName
-- instance UpdateOver CollectM QualifiedName (Pascal a)
-- instance UpdateOver CollectM Path (Pascal a)
-- instance UpdateOver CollectM Name (Pascal a)
-- instance UpdateOver CollectM TypeName (Pascal a)
-- instance UpdateOver CollectM FieldName (Pascal a)

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

@ -48,7 +48,7 @@ data Failure = Failure String
deriving anyclass (Exception) deriving anyclass (Exception)
instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where
enter (_ :> _ :> _) (ParseTree ty cs s) = do before (_ :> _ :> _) (ParseTree ty cs s) = do
let (comms, rest) = allComments cs let (comms, rest) = allComments cs
let (comms1, _) = allComments $ reverse rest let (comms1, _) = allComments $ reverse rest
modify $ first (++ comms) modify $ first (++ comms)
@ -57,7 +57,7 @@ instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where
let errs = allErrors cs let errs = allErrors cs
tell $ fmap Err errs tell $ fmap Err errs
leave _ _ = do after _ _ = do
modify \(x, y) -> (y, []) modify \(x, y) -> (y, [])
grabComments :: ParserM [Text] grabComments :: ParserM [Text]

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

@ -41,7 +41,7 @@ extra-deps:
- semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909 - semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909
- fastsum-0.1.1.1 - fastsum-0.1.1.1
- git: https://github.com/serokell/duplo.git - git: https://github.com/serokell/duplo.git
commit: 8fb7a22d0e6ff75ec049c36c6f767ee14e841446 commit: 325aefe2a0e6c7a6bdd08935be669da308ed0cb1
# - acme-missiles-0.3 # - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git # - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

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

@ -45,11 +45,11 @@ packages:
git: https://github.com/serokell/duplo.git git: https://github.com/serokell/duplo.git
pantry-tree: pantry-tree:
size: 557 size: 557
sha256: b5d8c86a8a26bc2efc0f86314317fa36b5f57c5d44cb889bee58f10782767037 sha256: adf7b6a5ae51a4ffa8a8db534bc030fb61209cc0be28c3bf82864267e40346c7
commit: 8fb7a22d0e6ff75ec049c36c6f767ee14e841446 commit: 325aefe2a0e6c7a6bdd08935be669da308ed0cb1
original: original:
git: https://github.com/serokell/duplo.git git: https://github.com/serokell/duplo.git
commit: 8fb7a22d0e6ff75ec049c36c6f767ee14e841446 commit: 325aefe2a0e6c7a6bdd08935be669da308ed0cb1
snapshots: snapshots:
- completed: - completed:
size: 493124 size: 493124