From c603cd399d72920b95b7769d8a5b192b372ff9c5 Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Thu, 30 Apr 2020 17:58:35 +0400 Subject: [PATCH] Refactor AST -> types/parser, extract Range/Printer --- tools/lsp/squirrel/squirrel.cabal | 6 +- tools/lsp/squirrel/src/AST.hs | 238 +------------------------- tools/lsp/squirrel/src/AST/Parser.hs | 131 ++++++++++++++ tools/lsp/squirrel/src/AST/Types.hs | 117 +++++++++++++ tools/lsp/squirrel/src/ParseTree.hs | 50 +++--- tools/lsp/squirrel/src/Parser.hs | 1 + tools/lsp/squirrel/src/PrettyPrint.hs | 11 ++ tools/lsp/squirrel/src/Range.hs | 12 ++ 8 files changed, 304 insertions(+), 262 deletions(-) create mode 100644 tools/lsp/squirrel/src/AST/Parser.hs create mode 100644 tools/lsp/squirrel/src/AST/Types.hs create mode 100644 tools/lsp/squirrel/src/PrettyPrint.hs create mode 100644 tools/lsp/squirrel/src/Range.hs diff --git a/tools/lsp/squirrel/squirrel.cabal b/tools/lsp/squirrel/squirrel.cabal index 1537987ec..3878f4801 100644 --- a/tools/lsp/squirrel/squirrel.cabal +++ b/tools/lsp/squirrel/squirrel.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 67ec249f56014b97ea36ef06bb0dad0986e0f632e7fe62dc4393a5a081cb0493 +-- hash: f4f92cb29b0c7d516e57ceee58c9d82900fc41d82cf21f7aa033094288165072 name: squirrel version: 0.0.0 @@ -13,8 +13,12 @@ build-type: Simple library exposed-modules: AST + AST.Parser + AST.Types Parser ParseTree + PrettyPrint + Range other-modules: Paths_squirrel hs-source-dirs: diff --git a/tools/lsp/squirrel/src/AST.hs b/tools/lsp/squirrel/src/AST.hs index 38b1e6424..fe8a15e9a 100644 --- a/tools/lsp/squirrel/src/AST.hs +++ b/tools/lsp/squirrel/src/AST.hs @@ -1,237 +1,5 @@ -{- annotate tree with ranges, add offsets to ranges, store verbatim in Wrong* -} +module AST (module M) where -module AST where - -import Control.Monad.State - -import qualified Data.Text as Text -import Data.Text (Text) -import Data.Void - -import Parser -import ParseTree - -import Debug.Trace - -type TODO = Text - -data Contract info - = Contract info [Declaration info] - | WrongContract Error - deriving stock (Show) - -instance Stubbed (Contract info) where stub = WrongContract - -data Declaration info - = ValueDecl info (Binding info) - | WrongDecl Error - deriving stock (Show) - -instance Stubbed (Declaration info) where stub = WrongDecl - -data Binding info - = Irrefutable info (Pattern info) (Expr info) - | Function info Bool (Name info) [VarDecl info] (Type info) TODO - | WrongBinding Error - deriving stock (Show) - -instance Stubbed (Binding info) where stub = WrongBinding - -data VarDecl info - = Decl info (Mutable info) (Name info) (Type info) - | WrongVarDecl Error - deriving stock (Show) - -instance Stubbed (VarDecl info) where stub = WrongVarDecl - -data Mutable info - = Mutable info - | Immutable info - | WrongMutable Error - deriving stock (Show) - -instance Stubbed (Mutable info) where stub = WrongMutable - -data Type info - = TArrow info (Type info) (Type info) - | Record info [(Name info, Type info)] - | TVar info (Name info) - | Sum info [(Name info, [Type info])] - | Product info [Type info] - | TApply info (Name info) [Type info] - | WrongType Error - deriving stock (Show) - -instance Stubbed (Type info) where stub = WrongType - -data Expr info - = Let info [Declaration info] (Expr info) - | Apply info (Expr info) (Expr info) - | Constant info (Constant info) - | Ident info (QualifiedName info) - | WrongExpr Error - deriving stock (Show) - -instance Stubbed (Expr info) where stub = WrongExpr - -data Constant info - = Int info Int - | String info Text - | Float info Double - | Bytes info Text - | WrongConstant Error - deriving stock (Show) - -instance Stubbed (Constant info) where stub = WrongConstant - -data Pattern info - = IsConstr info (Name info) [Pattern info] - | IsConstant info (Constant info) - | IsVar info (Name info) - | WrongPattern Error - deriving stock (Show) - -instance Stubbed (Pattern info) where stub = WrongPattern - -data QualifiedName info = QualifiedName - { source :: Name info - , path :: [Name info] - } - | WrongQualifiedName Error - deriving stock (Show) - -instance Stubbed (QualifiedName info) where stub = WrongQualifiedName - -data Name info = Name - { info :: info - , raw :: Text - } - | WrongName Error - -instance Stubbed (Name info) where stub = WrongName - -instance Show (Name info) where - show = \case - Name _ raw -> Text.unpack raw - WrongName r -> "(Name? " ++ show r ++ ")" - -name :: Parser (Name Range) -name = do - (raw, info) <- range (token "Name") - return Name {info, raw} - -contract :: Parser (Contract Range) -contract = subtree "contract" do - (decls, info) <- range do - many "declaration" declaration - return (Contract info decls) - -declaration :: Parser (Declaration Range) -declaration = - stubbed "declaration" do - field "declaration" do - (b, info) <- range binding - return (ValueDecl info b) - -par x = do - consume "(" - a <- x - consume ")" - return a - -binding :: Parser (Binding Range) -binding = do - info <- getRange - "fun_decl" `subtree` do - recur <- optional do - field "recursive" do - token "recursive" - consume "function" - name <- stubbed "name" do - field "name" do - name - params <- - field "parameters" do - subtree "parameters" do - par do - many "param" do - notFollowedBy do - consumeOrDie ")" - - stubbed "parameters" do - paramDecl - consume ":" - ty <- - stubbed "type" do - field "type" type_ - consume "is" - expr <- stubbed "body" do - field "locals" anything - return (Function info (recur == Just "recursive") name params ty expr) - -paramDecl :: Parser (VarDecl Range) -paramDecl = do - info <- getRange - "parameter" `field` do - subtree "param_decl" do - info' <- getRange - mutable <- do - traceM "paramDecl" - stubbed "access" do - "access" `subtree` do - traceM "paramDecl" - select - [ consume "var" >> return (Mutable info') - , consume "const" >> return (Immutable info') - ] - name <- - stubbed "name" do - field "name" name - consume ":" - ty <- - stubbed "type" do - field "type" type_ - return (Decl info mutable name ty) - -newtype_ = do - type_ - -type_ :: Parser (Type Range) -type_ = - fun_type - where - fun_type :: Parser (Type Range) - fun_type = do - stubbed "type" do - subtree "fun_type" do - info <- getRange - domain <- stubbed "domain" do - field "domain" cartesian - codomain <- optional do - consume "->" - fun_type - return case codomain of - Just co -> TArrow info domain co - Nothing -> domain - - cartesian = do - stubbed "cartesian" do - subtree "cartesian" do - info <- getRange - Product info <$> some "corety" do - field "element" do - core_type - - core_type = do - info <- getRange - select - [ TVar info <$> typename - ] - - typename = name - -tuple :: Text -> Parser a -> Parser [a] -tuple msg = par . some msg - -example = "../../../src/test/contracts/address.ligo" \ No newline at end of file +import AST.Types as M +import AST.Parser as M \ No newline at end of file diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs new file mode 100644 index 000000000..a1880700f --- /dev/null +++ b/tools/lsp/squirrel/src/AST/Parser.hs @@ -0,0 +1,131 @@ + +module AST.Parser where + +import Data.Text (Text) + +import AST.Types + +import Parser +import Range + +import Debug.Trace + +name :: Parser (Name Range) +name = do + (raw, info) <- range (token "Name") + return Name {info, raw} + +contract :: Parser (Contract Range) +contract = subtree "contract" do + (decls, info) <- range do + many "declaration" declaration + return (Contract info decls) + +declaration :: Parser (Declaration Range) +declaration = + stubbed "declaration" do + field "declaration" do + (b, info) <- range binding + return (ValueDecl info b) + +par x = do + consume "(" + a <- x + consume ")" + return a + +binding :: Parser (Binding Range) +binding = do + info <- getRange + "fun_decl" `subtree` do + recur <- optional do + field "recursive" do + token "recursive" + consume "function" + name <- stubbed "name" do + field "name" do + name + params <- + field "parameters" do + subtree "parameters" do + par do + many "param" do + notFollowedBy do + consumeOrDie ")" + + stubbed "parameters" do + paramDecl + consume ":" + ty <- + stubbed "type" do + field "type" type_ + consume "is" + expr <- stubbed "body" do + field "locals" anything + return (Function info (recur == Just "recursive") name params ty expr) + +paramDecl :: Parser (VarDecl Range) +paramDecl = do + info <- getRange + "parameter" `field` do + subtree "param_decl" do + info' <- getRange + mutable <- do + traceM "paramDecl" + stubbed "access" do + "access" `subtree` do + traceM "paramDecl" + select + [ consume "var" >> return (Mutable info') + , consume "const" >> return (Immutable info') + ] + name <- + stubbed "name" do + field "name" name + consume ":" + ty <- + stubbed "type" do + field "type" type_ + return (Decl info mutable name ty) + +newtype_ = do + type_ + +type_ :: Parser (Type Range) +type_ = + fun_type + where + fun_type :: Parser (Type Range) + fun_type = do + stubbed "type" do + subtree "fun_type" do + info <- getRange + domain <- stubbed "domain" do + field "domain" cartesian + codomain <- optional do + consume "->" + fun_type + return case codomain of + Just co -> TArrow info domain co + Nothing -> domain + + cartesian = do + stubbed "cartesian" do + subtree "cartesian" do + info <- getRange + Product info <$> some "corety" do + field "element" do + core_type + + core_type = do + info <- getRange + select + [ TVar info <$> typename + ] + + typename = name + +tuple :: Text -> Parser a -> Parser [a] +tuple msg = par . some msg + +example = "../../../src/test/contracts/address.ligo" diff --git a/tools/lsp/squirrel/src/AST/Types.hs b/tools/lsp/squirrel/src/AST/Types.hs new file mode 100644 index 000000000..755c2b948 --- /dev/null +++ b/tools/lsp/squirrel/src/AST/Types.hs @@ -0,0 +1,117 @@ + +{- annotate tree with ranges, add offsets to ranges, store verbatim in Wrong* -} + +module AST.Types where + +import Control.Monad.State + +import qualified Data.Text as Text +import Data.Text (Text) +import Data.Void + +import Parser +import ParseTree + +import Debug.Trace + +type TODO = Text + +data Contract info + = Contract info [Declaration info] + | WrongContract Error + deriving stock (Show) + +instance Stubbed (Contract info) where stub = WrongContract + +data Declaration info + = ValueDecl info (Binding info) + | WrongDecl Error + deriving stock (Show) + +instance Stubbed (Declaration info) where stub = WrongDecl + +data Binding info + = Irrefutable info (Pattern info) (Expr info) + | Function info Bool (Name info) [VarDecl info] (Type info) TODO + | WrongBinding Error + deriving stock (Show) + +instance Stubbed (Binding info) where stub = WrongBinding + +data VarDecl info + = Decl info (Mutable info) (Name info) (Type info) + | WrongVarDecl Error + deriving stock (Show) + +instance Stubbed (VarDecl info) where stub = WrongVarDecl + +data Mutable info + = Mutable info + | Immutable info + | WrongMutable Error + deriving stock (Show) + +instance Stubbed (Mutable info) where stub = WrongMutable + +data Type info + = TArrow info (Type info) (Type info) + | Record info [(Name info, Type info)] + | TVar info (Name info) + | Sum info [(Name info, [Type info])] + | Product info [Type info] + | TApply info (Name info) [Type info] + | WrongType Error + deriving stock (Show) + +instance Stubbed (Type info) where stub = WrongType + +data Expr info + = Let info [Declaration info] (Expr info) + | Apply info (Expr info) (Expr info) + | Constant info (Constant info) + | Ident info (QualifiedName info) + | WrongExpr Error + deriving stock (Show) + +instance Stubbed (Expr info) where stub = WrongExpr + +data Constant info + = Int info Int + | String info Text + | Float info Double + | Bytes info Text + | WrongConstant Error + deriving stock (Show) + +instance Stubbed (Constant info) where stub = WrongConstant + +data Pattern info + = IsConstr info (Name info) [Pattern info] + | IsConstant info (Constant info) + | IsVar info (Name info) + | WrongPattern Error + deriving stock (Show) + +instance Stubbed (Pattern info) where stub = WrongPattern + +data QualifiedName info = QualifiedName + { source :: Name info + , path :: [Name info] + } + | WrongQualifiedName Error + deriving stock (Show) + +instance Stubbed (QualifiedName info) where stub = WrongQualifiedName + +data Name info = Name + { info :: info + , raw :: Text + } + | WrongName Error + +instance Stubbed (Name info) where stub = WrongName + +instance Show (Name info) where + show = \case + Name _ raw -> Text.unpack raw + WrongName r -> "(Name? " ++ show r ++ ")" diff --git a/tools/lsp/squirrel/src/ParseTree.hs b/tools/lsp/squirrel/src/ParseTree.hs index 5507061d2..a75fd7ca6 100644 --- a/tools/lsp/squirrel/src/ParseTree.hs +++ b/tools/lsp/squirrel/src/ParseTree.hs @@ -29,6 +29,9 @@ import Text.PrettyPrint hiding ((<>)) import Paths_squirrel +import Range +import PrettyPrint + -- import Debug.Trace foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language @@ -52,38 +55,33 @@ data ParseForest = Forest } instance Show ParseTree where - show = show . ppTree + show = show . pp instance Show ParseForest where - show = show . vcat . map ppPair . pfGrove + show = show . pp -data Range = Range - { rStart :: (Int, Int) - , rFinish :: (Int, Int) - } - deriving stock (Show) - -diffRange :: Range -> Range -> Range -diffRange (Range ws wf) (Range ps _) = Range (max ws ps) wf - -ppTree :: ParseTree -> Doc -ppTree (ParseTree _ n _ _ (Range (sr, sc) (fr, fc)) (Forest _ cs _)) = - parens - ( hang - ( quotes (text (Text.unpack n)) - <+> brackets - ( int sr <> ":" <> int sc - <> " - " - <> int fr <> ":" <> int fc +instance Pretty ParseTree where + pp (ParseTree _ n _ _ (Range (sr, sc) (fr, fc)) forest) = + parens + ( hang + ( quotes (text (Text.unpack n)) + <+> brackets + ( int sr <> ":" <> int sc + <> " - " + <> int fr <> ":" <> int fc + ) ) + 2 + (pp forest) ) - 2 - (vcat (map ppPair cs))) -ppPair (field, tree) = - if field == Text.empty - then nest 2 $ ppTree tree - else hang (text (Text.unpack field) <> ": ") 2 (ppTree tree) +instance Pretty ParseForest where + pp = vcat . map ppPair . pfGrove + where + ppPair (field, tree) = + if field == Text.empty + then nest 2 $ pp tree + else hang (text (Text.unpack field) <> ": ") 2 (pp tree) toParseTree :: FilePath -> IO ParseForest toParseTree fin = do diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index e64cb487a..2d3150b3e 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/tools/lsp/squirrel/src/Parser.hs @@ -14,6 +14,7 @@ import qualified Data.ByteString as ByteString import Data.ByteString (ByteString) import ParseTree +import Range import Debug.Trace diff --git a/tools/lsp/squirrel/src/PrettyPrint.hs b/tools/lsp/squirrel/src/PrettyPrint.hs new file mode 100644 index 000000000..d8d3e69ee --- /dev/null +++ b/tools/lsp/squirrel/src/PrettyPrint.hs @@ -0,0 +1,11 @@ + +module PrettyPrint + ( module PrettyPrint + , module Text.PrettyPrint + ) + where + +import Text.PrettyPrint hiding ((<>)) + +class Pretty p where + pp :: p -> Doc \ No newline at end of file diff --git a/tools/lsp/squirrel/src/Range.hs b/tools/lsp/squirrel/src/Range.hs new file mode 100644 index 000000000..6bd940b66 --- /dev/null +++ b/tools/lsp/squirrel/src/Range.hs @@ -0,0 +1,12 @@ + +module Range where + +data Range = Range + { rStart :: (Int, Int) + , rFinish :: (Int, Int) + } + deriving stock (Show) + +diffRange :: Range -> Range -> Range +diffRange (Range ws wf) (Range ps _) = Range (max ws ps) wf +