From f554551f75c16b9b38bdbc8bc5be8c4cace733ea Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Mon, 24 Aug 2020 12:29:51 +0400 Subject: [PATCH] [LIGO-37] [LIGO-38] Looks like it fixes it --- tools/lsp/squirrel/src/AST/Camligo/Parser.hs | 14 +-- .../lsp/squirrel/src/AST/Pascaligo/Parser.hs | 10 +- .../lsp/squirrel/src/AST/Reasonligo/Parser.hs | 2 +- tools/lsp/squirrel/src/AST/Scope.hs | 92 +++++++++++++++---- tools/lsp/squirrel/src/AST/Skeleton.hs | 4 +- tools/lsp/squirrel/src/ParseTree.hs | 4 +- tools/lsp/squirrel/src/Product.hs | 3 - 7 files changed, 90 insertions(+), 39 deletions(-) diff --git a/tools/lsp/squirrel/src/AST/Camligo/Parser.hs b/tools/lsp/squirrel/src/AST/Camligo/Parser.hs index 067302a9e..be281d7ae 100644 --- a/tools/lsp/squirrel/src/AST/Camligo/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Camligo/Parser.hs @@ -68,13 +68,13 @@ example :: FilePath -- example = "../../../src/test/contracts/let_in_multi_bind.mligo" example = "../../../src/test/contracts/fibo2.mligo" -raw :: IO () -raw = toParseTree (Path example) - >>= print . pp +-- raw :: IO () +-- raw = toParseTree (Path example) +-- >>= print . pp -raw' :: FilePath -> IO () -raw' example = toParseTree (Path example) - >>= print . pp +-- raw' :: FilePath -> IO () +-- raw' example = toParseTree (Path example) +-- >>= print . pp sample :: IO () sample @@ -89,7 +89,7 @@ sample' example >>= print . pp . fst recognise :: RawTree -> ParserM (LIGO Info) -recognise = descent (\_ -> error . show . pp) $ map usingScope +recognise = descent (error "Reasonligo.recognise") $ map usingScope [ -- Contract Descent do boilerplate $ \case diff --git a/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs b/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs index 45ed7c400..dea15a431 100644 --- a/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs @@ -43,10 +43,10 @@ import ParseTree -- >>= runParserM . recognise -- >>= return . fst -source' :: FilePath -> IO () -source' f - = toParseTree (Path f) - >>= print . pp +-- source' :: FilePath -> IO () +-- source' f +-- = toParseTree (Path f) +-- >>= print . pp -- sample :: IO () -- sample @@ -60,7 +60,7 @@ source' f -- >>= print . pp recognise :: RawTree -> ParserM (LIGO Info) -recognise = descent (\_ -> error . show . pp) $ map usingScope +recognise = descent (error "Reasonligo.recognise") $ map usingScope [ -- Contract Descent do boilerplate \case diff --git a/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs b/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs index f4c8ba355..a71a0ac02 100644 --- a/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs @@ -44,7 +44,7 @@ import Product -- >>= print . pp . fst recognise :: RawTree -> ParserM (LIGO Info) -recognise = descent (\_ -> error . show . pp) $ map usingScope +recognise = descent (error "Reasonligo.recognise") $ map usingScope [ -- Contract Descent do boilerplate $ \case diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index 3e677ec6b..3356152c3 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/tools/lsp/squirrel/src/AST/Scope.hs @@ -17,7 +17,9 @@ import Control.Arrow (second) import Control.Monad.State import Control.Monad.Catch import Control.Monad.Catch.Pure +import Control.Monad.Writer (WriterT, execWriterT, tell) +import Data.Monoid (First(getFirst)) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map @@ -46,7 +48,7 @@ data Category = Variable | Type -- | The type/value declaration. data ScopedDecl = ScopedDecl - { _sdName :: LIGO () + { _sdName :: Text , _sdOrigin :: Range , _sdBody :: Maybe Range , _sdType :: Maybe (Either (LIGO ()) Kind) @@ -98,12 +100,6 @@ ofCategory _ _ = False type Info' = Product [[ScopedDecl], Maybe Category, [Text], Range, ShowRange] --- instance Modifies (Product '[[ScopedDecl], Maybe Category, [Text], Range, a]) where --- ascribe (ds :> _ :> _ :> r :> _) d = --- color 3 (fsep (map (pp . _sdName) ds)) --- $$ pp r --- $$ d - addLocalScopes :: forall xs . (Collectable xs, Eq (Product xs)) @@ -290,16 +286,18 @@ lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName) -- | Add a type declaration to the current scope. -defType :: HasRange a => LIGO a -> Kind -> LIGO a -> [Text] -> CollectM () -defType name kind body doc = do +defType :: Collectable xs => LIGO (Product xs) -> Kind -> LIGO (Product xs) -> [Text] -> CollectM () +defType name' kind body doc = do define Type $ ScopedDecl - (void name) - (getRange $ extract name) + name + r (Just $ getRange $ extract body) (Just (Right kind)) [] doc + where + (r, name) = getTypeName name' -- -- observe :: Pretty i => Pretty res => Text -> i -> res -> res -- -- observe msg i res @@ -309,23 +307,79 @@ defType name kind body doc = do -- | Add a value declaration to the current scope. def - :: HasRange a - => LIGO a - -> Maybe (LIGO a) - -> Maybe (LIGO a) + :: Collectable xs + => LIGO (Product xs) + -> Maybe (LIGO (Product xs)) + -> Maybe (LIGO (Product xs)) -> [Text] -> CollectM () -def name ty body doc = do +def name' ty body doc = do define Variable $ ScopedDecl - (void name) - (getRange $ extract name) + name + r ((getRange . extract) <$> body) ((Left . void) <$> ty) [] doc + where + (r, name) = getName name' -type Collectable xs = (Contains Range xs, Contains [Text] xs) +select + :: ( Lattice (Product info) + , Contains ShowRange info + , Contains Range info + , Modifies (Product info) + , Eq (Product info) + ) + => Text + -> [Visit RawLigoList (Product info) (WriterT [LIGO (Product info)] Catch)] + -> LIGO (Product info) + -> (Range, Text) +select what handlers t + = maybe + (error . show $ "Tree does not contain a" <+> pp what <.> ":" <+> pp t <+> pp (getRange $ extract t)) + (\t -> (getElem $ extract t, ppToText t)) + $ either (const Nothing) listToMaybe + $ runCatch + $ execWriterT + $ visit handlers + t + +getName + :: ( Lattice (Product info) + , Contains ShowRange info + , Contains Range info + , Modifies (Product info) + , Eq (Product info) + ) + => LIGO (Product info) + -> (Range, Text) +getName = select "name" + [ Visit \(r, Name t) -> do + tell [make (r, Name t)] + ] + +getTypeName + :: ( Lattice (Product info) + , Contains ShowRange info + , Contains Range info + , Modifies (Product info) + , Eq (Product info) + ) + => LIGO (Product info) + -> (Range, Text) +getTypeName = select "type name" + [ Visit \(r, TypeName t) -> do + tell [make (r, TypeName t)] + ] + +type Collectable xs = + ( Contains Range xs + , Contains [Text] xs + , Contains ShowRange xs + , Eq (Product xs) + ) instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Contract where before r _ = enter r diff --git a/tools/lsp/squirrel/src/AST/Skeleton.hs b/tools/lsp/squirrel/src/AST/Skeleton.hs index 6c7392f18..4bb2f0035 100644 --- a/tools/lsp/squirrel/src/AST/Skeleton.hs +++ b/tools/lsp/squirrel/src/AST/Skeleton.hs @@ -383,11 +383,11 @@ instance Pretty1 Pattern where instance Pretty1 Name where pp1 = \case - Name raw -> color 2 $ pp raw + Name raw -> pp raw instance Pretty1 TypeName where pp1 = \case - TypeName raw -> color 3 $ pp raw + TypeName raw -> pp raw instance Pretty1 FieldName where pp1 = \case diff --git a/tools/lsp/squirrel/src/ParseTree.hs b/tools/lsp/squirrel/src/ParseTree.hs index 260cfc425..ec6027d3a 100644 --- a/tools/lsp/squirrel/src/ParseTree.hs +++ b/tools/lsp/squirrel/src/ParseTree.hs @@ -66,8 +66,8 @@ srcToBytestring = \case type RawTree = Tree '[ParseTree] RawInfo type RawInfo = Product [Range, Text] -instance {-# OVERLAPS #-} Modifies RawInfo where - ascribe (r :> n :> _) d = color 3 (pp n) <+> pp r `indent` pp d +-- instance {-# OVERLAPS #-} Modifies RawInfo where +-- ascribe (r :> n :> _) d = color 3 (pp n) <+> pp r `indent` pp d data TreeKind = Error diff --git a/tools/lsp/squirrel/src/Product.hs b/tools/lsp/squirrel/src/Product.hs index 448a000c4..06f613181 100644 --- a/tools/lsp/squirrel/src/Product.hs +++ b/tools/lsp/squirrel/src/Product.hs @@ -55,9 +55,6 @@ instance Eq (Product '[]) where instance (Eq x, Eq (Product xs)) => Eq (Product (x : xs)) where x :> xs == y :> ys = and [x == y, xs == ys] --- instance Modifies (Product xs) where --- ascribe _ = id - class PrettyProd xs where ppProd :: Product xs -> Doc