[LIGO-25] Add ReasonLIGO parser
Problem: With generated ReasonLIGO grammar we need to develop its parser as well. With it we also need to restructure AST a bit and add expressions that are used for ReasonLIGO specifically. Solution: Add ReasonLIGO parser and some dummy examples of its usage, adapt AST to it, rename LIGO to AST.
This commit is contained in:
Anton Myasnikov
parent
820d73f345
commit
a1a846b554
@ -25,7 +25,6 @@ import Language.Haskell.LSP.VFS
|
||||
import System.Exit
|
||||
import qualified System.Log as L
|
||||
|
||||
import Duplo.Pretty
|
||||
import Duplo.Error
|
||||
import Duplo.Tree (collect)
|
||||
|
||||
@ -35,6 +34,7 @@ import Range
|
||||
import Product
|
||||
import AST hiding (def)
|
||||
import qualified AST.Find as Find
|
||||
import AST.Pascaligo.Parser
|
||||
-- import Error
|
||||
|
||||
main :: IO ()
|
||||
@ -219,7 +219,7 @@ loadFromVFS funs uri = do
|
||||
Just vf <- Core.getVirtualFileFunc funs $ J.toNormalizedUri uri
|
||||
let txt = virtualFileText vf
|
||||
let Just fin = J.uriToFilePath uri
|
||||
(tree, _) <- runParserM . recognise =<< toParseTree (Text fin txt)
|
||||
(tree, _) <- runParserM . recognise =<< mkRawTreePascal (Text fin txt)
|
||||
return $ addLocalScopes tree
|
||||
|
||||
-- loadByURI
|
||||
@ -242,7 +242,7 @@ collectErrors
|
||||
collectErrors funs uri path version = do
|
||||
case path of
|
||||
Just fin -> do
|
||||
(tree, errs) <- runParserM . recognise =<< toParseTree (Path fin)
|
||||
(tree, errs) <- runParserM . recognise =<< mkRawTreePascal (Path fin)
|
||||
Core.publishDiagnosticsFunc funs 100 uri version
|
||||
$ partitionBySource
|
||||
$ map errorToDiag (errs <> map (getElem *** void) (collect tree))
|
||||
|
||||
@ -1,11 +1,7 @@
|
||||
|
||||
{- | The "all things AST"-module.
|
||||
-}
|
||||
|
||||
-- | The "all things AST"-module.
|
||||
module AST (module M) where
|
||||
|
||||
import AST.Types as M
|
||||
import AST.Parser as M
|
||||
import AST.Scope as M
|
||||
import AST.Find as M
|
||||
import AST.Completion as M
|
||||
import AST.Find as M
|
||||
import AST.Scope as M
|
||||
import AST.Skeleton as M
|
||||
|
||||
@ -2,22 +2,19 @@
|
||||
module AST.Completion where
|
||||
|
||||
import Data.Function (on)
|
||||
import Data.List (isSubsequenceOf, nubBy)
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.List (isSubsequenceOf, nubBy)
|
||||
|
||||
import Duplo.Tree
|
||||
import Duplo.Lattice
|
||||
import Duplo.Pretty
|
||||
import Duplo.Tree
|
||||
|
||||
import AST.Types
|
||||
import AST.Scope
|
||||
-- import AST.Parser
|
||||
import Range
|
||||
import AST.Skeleton
|
||||
import Product
|
||||
|
||||
import Debug.Trace
|
||||
import Range
|
||||
|
||||
data Completion = Completion
|
||||
{ cName :: Text
|
||||
|
||||
@ -5,20 +5,18 @@ import Control.Monad
|
||||
|
||||
import Data.Maybe (listToMaybe)
|
||||
|
||||
import Duplo.Tree
|
||||
import Duplo.Pretty
|
||||
import Duplo.Lattice
|
||||
import Duplo.Pretty
|
||||
import Duplo.Tree
|
||||
|
||||
import Data.Text (Text)
|
||||
|
||||
import AST.Types
|
||||
import AST.Scope
|
||||
import AST.Skeleton
|
||||
|
||||
import Product
|
||||
import Range
|
||||
|
||||
-- import Debug.Trace
|
||||
|
||||
type CanSearch xs =
|
||||
( Contains [ScopedDecl] xs
|
||||
, Contains Range xs
|
||||
|
||||
@ -1,14 +1,9 @@
|
||||
|
||||
{- | Parser for a contract.
|
||||
-}
|
||||
|
||||
module AST.Parser
|
||||
-- (example, contract, sample)
|
||||
where
|
||||
-- | Parser for a PascaLigo contract.
|
||||
module AST.Pascaligo.Parser where
|
||||
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
import AST.Types
|
||||
import AST.Skeleton
|
||||
|
||||
import Duplo.Error
|
||||
import Duplo.Tree
|
||||
@ -45,24 +40,24 @@ example = "../../../src/test/contracts/coase.ligo"
|
||||
|
||||
sample' :: FilePath -> IO (LIGO Info)
|
||||
sample' f
|
||||
= toParseTree (Path f)
|
||||
= mkRawTreePascal (Path f)
|
||||
>>= runParserM . recognise
|
||||
>>= return . fst
|
||||
|
||||
source' :: FilePath -> IO ()
|
||||
source' f
|
||||
= toParseTree (Path f)
|
||||
= mkRawTreePascal (Path f)
|
||||
>>= print . pp
|
||||
|
||||
sample :: IO ()
|
||||
sample
|
||||
= toParseTree (Path example)
|
||||
= mkRawTreePascal (Path example)
|
||||
>>= runParserM . recognise
|
||||
>>= print . pp . fst
|
||||
|
||||
source :: IO ()
|
||||
source
|
||||
= toParseTree (Path example)
|
||||
= mkRawTreePascal (Path example)
|
||||
>>= print . pp
|
||||
|
||||
recognise :: RawTree -> ParserM (LIGO Info)
|
||||
@ -100,7 +95,7 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
|
||||
"skip" -> return Skip
|
||||
"case_expr" -> Case <$> field "subject" <*> fields "case"
|
||||
"case_instr" -> Case <$> field "subject" <*> fields "case"
|
||||
"fun_expr" -> Lambda <$> field "parameters" <*> field "type" <*> field "body"
|
||||
"fun_expr" -> Lambda <$> field "parameters" <*> fieldOpt "type" <*> field "body"
|
||||
"for_cycle" -> ForLoop <$> field "name" <*> field "begin" <*> field "end" <*> fieldOpt "step" <*> field "body"
|
||||
"for_box" -> ForBox <$> field "key" <*> fieldOpt "value" <*> field "kind" <*> field "collection" <*> field "body"
|
||||
"while_loop" -> WhileLoop <$> field "breaker" <*> field "body"
|
||||
@ -175,7 +170,7 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
|
||||
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"
|
||||
"var_decl" -> Var <$> field "name" <*> fieldOpt "type" <*> field "value"
|
||||
"type_decl" -> TypeDecl <$> field "typeName" <*> field "typeValue"
|
||||
"include" -> Include <$> field "filename"
|
||||
_ -> fallthrough
|
||||
225
tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs
Normal file
225
tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs
Normal file
@ -0,0 +1,225 @@
|
||||
-- | Parser for ReasonLigo contract
|
||||
|
||||
module AST.Reasonligo.Parser where
|
||||
|
||||
import Duplo.Error
|
||||
import Duplo.Pretty
|
||||
import Duplo.Tree
|
||||
|
||||
import AST.Skeleton
|
||||
|
||||
import Parser
|
||||
import ParseTree
|
||||
import Product
|
||||
|
||||
example :: FilePath
|
||||
-- example = "../../../src/test/contracts/counter.religo"
|
||||
-- example = "./contracts/variant.religo"
|
||||
-- example = "./contracts/amount.religo"
|
||||
example = "./contracts/multisig.religo"
|
||||
-- example = "../../../src/test/contracts/FA1.2.religo"
|
||||
-- example = "../../../src/test/contracts/multisig.religo"
|
||||
-- example = "../../../src/test/contracts/lambda.religo"
|
||||
-- example = "../../../src/test/contracts/record.religo"
|
||||
-- example = "../../../src/test/contracts/tuple_type.religo"
|
||||
-- example = "../../../src/test/contracts/empty_case.religo"
|
||||
-- example = "./contracts/empty_case.religo"
|
||||
-- example = "./contracts/tuple_type.religo"
|
||||
-- example = "./contracts/assert.religo"
|
||||
-- example = "./contracts/tuples_no_annotation.religo"
|
||||
-- example = "./contracts/match.religo"
|
||||
-- example = "./contracts/let_multiple.religo"
|
||||
-- example = "./contracts/attributes.religo"
|
||||
-- example = "./contracts/lambda.religo"
|
||||
-- example = "./contracts/arithmetic.religo"
|
||||
-- example = "./contracts/letin.religo"
|
||||
|
||||
raw :: IO ()
|
||||
raw = mkRawTreeReason (Path example)
|
||||
>>= print . pp
|
||||
|
||||
sample :: IO ()
|
||||
sample = mkRawTreeReason (Path example)
|
||||
>>= runParserM . recognise
|
||||
>>= print . pp . fst
|
||||
|
||||
recognise :: RawTree -> ParserM (LIGO Info)
|
||||
recognise = descent (\_ -> error . show . pp) $ map usingScope
|
||||
[ -- Contract
|
||||
Descent do
|
||||
boilerplate $ \case
|
||||
"contract" -> RawContract <$> fields "declaration"
|
||||
_ -> fallthrough
|
||||
|
||||
-- ReasonExpr
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"bracket_block" -> Block <$> fields "statement" <*> fieldOpt "return"
|
||||
_ -> fallthrough
|
||||
|
||||
|
||||
-- Expr
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"fun_call" -> Apply <$> field "f" <*> field "arguments"
|
||||
"lambda_call" -> Apply <$> field "lambda" <*> field "arguments" -- TODO: maybe a separate apply?
|
||||
"arguments" -> Tuple <$> fields "argument"
|
||||
"unary_call" -> UnOp <$> field "negate" <*> field "arg"
|
||||
"binary_call" -> BinOp <$> field "left" <*> field "op" <*> field "right"
|
||||
"constructor_call" -> Apply <$> field "constructor" <*> field "parameters"
|
||||
"block" -> Seq <$> fields "statement"
|
||||
"list_expr" -> List <$> fields "element"
|
||||
"list_access" -> ListAccess <$> field "name" <*> fields "indexes"
|
||||
"annot_expr" -> Annot <$> field "subject" <*> field "type"
|
||||
"conditional" -> If <$> field "selector" <*> field "then" <*> field "else"
|
||||
"record_expr" -> Record <$> fields "assignment"
|
||||
"tuple_expr" -> Tuple <$> fields "element"
|
||||
|
||||
"switch_instr" -> Case <$> field "subject" <*> fields "case"
|
||||
"lambda" -> Lambda <$> field "arguments" <*> fieldOpt "lambda_type" <*> field "lambda_body"
|
||||
_ -> fallthrough
|
||||
|
||||
-- Pattern
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"constr_pattern" -> IsConstr <$> field "constr" <*> fieldOpt "arguments"
|
||||
"tuple_pattern" -> IsTuple <$> fields "element"
|
||||
"cons_pattern" -> IsCons <$> field "head" <*> field "tail"
|
||||
"annot_pattern" -> IsAnnot <$> field "subject" <*> field "type"
|
||||
_ -> fallthrough
|
||||
|
||||
-- Alt
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"alt" -> Alt <$> field "pattern" <*> field "body"
|
||||
_ -> fallthrough
|
||||
|
||||
-- Record fields
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"record_field" -> FieldAssignment <$> field "name" <*> field "value"
|
||||
"spread" -> Spread <$> field "name"
|
||||
_ -> fallthrough
|
||||
|
||||
-- MapBinding
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"binding" -> MapBinding <$> field "key" <*> field "value"
|
||||
_ -> fallthrough
|
||||
|
||||
, Descent do
|
||||
boilerplate' $ \case
|
||||
("+", _) -> return $ Op "+"
|
||||
("-", _) -> return $ Op "-"
|
||||
("mod", _) -> return $ Op "mod"
|
||||
("/", _) -> return $ Op "/"
|
||||
("*", _) -> return $ Op "*"
|
||||
(">", _) -> return $ Op ">"
|
||||
("<", _) -> return $ Op "<"
|
||||
(">=", _) -> return $ Op ">="
|
||||
("<=", _) -> return $ Op "<="
|
||||
("==", _) -> return $ Op "=="
|
||||
("!=", _) -> return $ Op "!="
|
||||
("||", _) -> return $ Op "||"
|
||||
("&&", _) -> return $ Op "&&"
|
||||
("negate", n) -> return $ Op n
|
||||
_ -> fallthrough
|
||||
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"module_qualified" -> QualifiedName <$> field "module" <*> fields "method"
|
||||
"struct_qualified" -> QualifiedName <$> field "struct" <*> fields "method"
|
||||
_ -> fallthrough
|
||||
|
||||
-- Literal
|
||||
, 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 do
|
||||
boilerplate $ \case
|
||||
-- TODO: Current `Let` in ast is untyped
|
||||
"let_declaration" -> Var <$> field "binding" <*> fieldOpt "let_type" <*> field "let_value"
|
||||
"type_decl" -> TypeDecl <$> field "type_name" <*> field "type_value"
|
||||
"attr_decl" -> Attribute <$> field "name"
|
||||
_ -> fallthrough
|
||||
|
||||
-- Parameters
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"parameters" -> Parameters <$> fields "parameter"
|
||||
_ -> fallthrough
|
||||
|
||||
-- VarDecl
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"param_decl" -> Decl <$> field "access" <*> field "name" <*> field "type"
|
||||
_ -> fallthrough
|
||||
|
||||
-- Name
|
||||
, Descent do
|
||||
boilerplate' $ \case
|
||||
("Name", n) -> return $ Name n
|
||||
("and", _) -> return $ Name "and"
|
||||
("or", _) -> return $ Name "or"
|
||||
_ -> fallthrough
|
||||
|
||||
-- Type
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"fun_type" -> TArrow <$> field "domain" <*> field "codomain"
|
||||
-- TODO: maybe only one argument of parameter list is considered
|
||||
"type_application" -> TApply <$> field "functor" <*> field "parameter"
|
||||
"type_tuple" -> TTuple <$> fields "element"
|
||||
"record_type" -> TRecord <$> fields "field"
|
||||
"sum_type" -> TSum <$> fields "variant"
|
||||
_ -> fallthrough
|
||||
|
||||
-- Variant
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"variant" -> Variant <$> field "constructor" <*> fieldOpt "arguments"
|
||||
_ -> fallthrough
|
||||
|
||||
-- TField
|
||||
, Descent do
|
||||
boilerplate $ \case
|
||||
"field_decl" -> TField <$> field "field_name" <*> field "field_type"
|
||||
_ -> fallthrough
|
||||
|
||||
-- TypeName
|
||||
, Descent do
|
||||
boilerplate' $ \case
|
||||
("TypeName", name) -> return $ TypeName name
|
||||
_ -> fallthrough
|
||||
|
||||
-- Ctor
|
||||
, Descent do
|
||||
boilerplate' $ \case
|
||||
("Name_Capital", name) -> return $ Ctor name
|
||||
("Some", _) -> return $ Ctor "Some"
|
||||
("None", _) -> return $ Ctor "None"
|
||||
("Bool", b) -> return $ Ctor b
|
||||
("Unit", _) -> return $ Ctor "Unit"
|
||||
("Nil", _) -> return $ Ctor "Nil"
|
||||
_ -> fallthrough
|
||||
|
||||
-- Err
|
||||
, Descent do
|
||||
\(r :> _, ParseTree _ _ msg) -> do
|
||||
withComments do
|
||||
return (r :> N :> Nil, Err msg)
|
||||
|
||||
, Descent do
|
||||
\case
|
||||
(r :> _, ParseTree "ERROR" _ msg) -> do
|
||||
return ([] :> r :> Y :> Nil, Err msg)
|
||||
|
||||
_ -> fallthrough
|
||||
]
|
||||
@ -29,8 +29,7 @@ import Duplo.Pretty
|
||||
import Duplo.Tree
|
||||
import Duplo.Error
|
||||
|
||||
-- import AST.Parser
|
||||
import AST.Types
|
||||
import AST.Skeleton
|
||||
import Parser
|
||||
import Product
|
||||
import Range
|
||||
@ -111,11 +110,12 @@ addLocalScopes
|
||||
=> LIGO (Product xs)
|
||||
-> LIGO (Product ([ScopedDecl] : Maybe Category : xs))
|
||||
addLocalScopes tree =
|
||||
fmap (\xs -> fullEnvAt envWithREfs (getRange xs) :> xs) tree1
|
||||
fmap (\xs -> fullEnvAt envWithRefs (getRange xs) :> xs) tree1
|
||||
where
|
||||
tree0 = either (error . show) id $ runCatch $ unLetRec tree
|
||||
tree1 = addNameCategories tree0
|
||||
envWithREfs = getEnvTree tree0
|
||||
-- envWithREfs = getEnvTree tree0
|
||||
envWithRefs = undefined
|
||||
|
||||
unLetRec
|
||||
:: forall xs m
|
||||
@ -348,7 +348,7 @@ instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Bind
|
||||
|
||||
after r = \case
|
||||
Irrefutable name body -> do leave; def name Nothing (Just body) (getElem r)
|
||||
Var name ty body -> do leave; def name (Just ty) (Just body) (getElem r)
|
||||
Var name ty body -> do leave; def name ty (Just body) (getElem r) -- TODO: may be the source of bugs
|
||||
Const name ty body -> do leave; def name (Just ty) (Just body) (getElem r)
|
||||
|
||||
Function recur name _args ty body -> do
|
||||
@ -412,4 +412,4 @@ instance Scoped a CollectM (LIGO a) FieldName
|
||||
instance Scoped a CollectM (LIGO a) (Err Text)
|
||||
instance Scoped a CollectM (LIGO a) Language
|
||||
instance Scoped a CollectM (LIGO a) Parameters
|
||||
instance Scoped a CollectM (LIGO a) Ctor
|
||||
-- instance Scoped a CollectM (LIGO a) Ctor(Contains Range xs, Eq (Product xs), Scoped (Product xs) CollectM (Tree RawLigoList (Product xs)) ReasonExpr)
|
||||
@ -4,17 +4,16 @@
|
||||
The comments for fields in types are the type before it was made untyped.
|
||||
-}
|
||||
|
||||
module AST.Types where
|
||||
module AST.Skeleton where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Duplo.Pretty
|
||||
import Duplo.Tree
|
||||
import Duplo.Error
|
||||
|
||||
-- import Debug.Trace
|
||||
|
||||
-- | The AST for Pascali... wait. It is, em, universal one.
|
||||
--
|
||||
-- TODO: Rename; add stuff if CamlLIGO/ReasonLIGO needs something.
|
||||
@ -25,9 +24,16 @@ type RawLigoList =
|
||||
[ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment
|
||||
, MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding
|
||||
, RawContract, TypeName, FieldName, Language
|
||||
, Err Text, Parameters, Ctor, Contract
|
||||
, Err Text, Parameters, Ctor, Contract, ReasonExpr
|
||||
]
|
||||
|
||||
-- | ReasonLigo specific expressions
|
||||
data ReasonExpr it
|
||||
-- TODO: Block may not need Maybe since last expr may be always `return`
|
||||
= Block [it] (Maybe it) -- [Declaration] (Return)
|
||||
deriving (Show) via PP (ReasonExpr it)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Undefined it
|
||||
= Undefined Text
|
||||
deriving (Show) via PP (Undefined it)
|
||||
@ -57,10 +63,11 @@ data RawContract it
|
||||
|
||||
data Binding it
|
||||
= Irrefutable it it -- ^ (Pattern) (Expr)
|
||||
| Function Bool it it it it -- ^ (Name) Parameters (Type) (Expr)
|
||||
| Var it it it -- ^ (Name) (Type) (Expr)
|
||||
| Function Bool it it it it -- ^ (Name) (Parameters) (Type) (Expr)
|
||||
| Var it (Maybe it) it -- ^ (Name) (Type) (Expr)
|
||||
| Const it it it -- ^ (Name) (Type) (Expr)
|
||||
| TypeDecl it it -- ^ Name Type
|
||||
| TypeDecl it it -- ^ (Name) (Type)
|
||||
| Attribute it -- ^ (Name)
|
||||
| Include it
|
||||
deriving (Show) via PP (Binding it)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
@ -118,6 +125,7 @@ data Expr it
|
||||
| If it it it -- (Expr) (Expr) (Expr)
|
||||
| Assign it it -- (LHS) (Expr)
|
||||
| List [it] -- [Expr]
|
||||
| ListAccess it [it] -- (Name) [Indexes]
|
||||
| Set [it] -- [Expr]
|
||||
| Tuple [it] -- [Expr]
|
||||
| Annot it it -- (Expr) (Type)
|
||||
@ -132,7 +140,7 @@ data Expr it
|
||||
| ForLoop it it it (Maybe it) it -- (Name) (Expr) (Expr) (Expr)
|
||||
| WhileLoop it it -- (Expr) (Expr)
|
||||
| Seq [it] -- [Declaration]
|
||||
| Lambda it it it -- [VarDecl] (Type) (Expr)
|
||||
| Lambda it (Maybe it) it -- [VarDecl] (Maybe (Type)) (Expr)
|
||||
| ForBox it (Maybe it) it it it -- (Name) (Maybe (Name)) Text (Expr) (Expr)
|
||||
| MapPatch it [it] -- (QualifiedName) [MapBinding]
|
||||
| SetPatch it [it] -- (QualifiedName) [Expr]
|
||||
@ -162,6 +170,7 @@ data Assignment it
|
||||
|
||||
data FieldAssignment it
|
||||
= FieldAssignment it it -- (QualifiedName) (Expr)
|
||||
| Spread it -- (Name)
|
||||
deriving (Show) via PP (FieldAssignment it)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
@ -180,6 +189,7 @@ data Pattern it
|
||||
| IsConstant it -- (Constant)
|
||||
| IsVar it -- (Name)
|
||||
| IsCons it it -- (Pattern) (Pattern)
|
||||
| IsAnnot it it -- (Pattern) (Type) -- Semantically `Var`
|
||||
| IsWildcard
|
||||
| IsList [it] -- [Pattern]
|
||||
| IsTuple [it] -- [Pattern]
|
||||
@ -239,8 +249,10 @@ instance Pretty1 Binding where
|
||||
pp1 = \case
|
||||
Irrefutable pat expr -> "irref" <+> pat <+> "=" `indent` expr
|
||||
TypeDecl n ty -> "type" <+> n <+> "=" `indent` ty
|
||||
Var name ty value -> "var" <+> name <+> ":" <+> ty <+> ":=" `indent` value
|
||||
-- TODO
|
||||
Var name ty value -> "var" <+> name <+> ":" <+> fromMaybe "<unnanotated>" ty <+> ":=" `indent` value
|
||||
Const name ty body -> "const" <+> name <+> ":" <+> ty <+> "=" `indent` body
|
||||
Attribute name -> "[@" <.> name <.> "]"
|
||||
Include fname -> "#include" <+> fname
|
||||
|
||||
Function isRec name params ty body ->
|
||||
@ -286,10 +298,18 @@ instance Pretty1 Variant where
|
||||
Variant ctor (Just ty) -> "|" <+> ctor <+> "of" `indent` ty
|
||||
Variant ctor _ -> "|" <+> ctor
|
||||
|
||||
instance Pretty1 ReasonExpr where
|
||||
pp1 = \case
|
||||
-- TODO: prettify
|
||||
Block decls ret -> "block' {"
|
||||
`indent` block decls
|
||||
<+> (if null decls then "" else ";")
|
||||
`above` maybe "" ("return" `indent`) ret `above` "}"
|
||||
|
||||
instance Pretty1 Expr where
|
||||
pp1 = \case
|
||||
Let decl body -> "let" <+> decl `above` body
|
||||
Apply f xs -> f <+> xs
|
||||
Apply f xs -> "(" <.> f <.> ")" <+> xs
|
||||
Constant constant -> constant
|
||||
Ident qname -> qname
|
||||
BinOp l o r -> parens (l <+> pp o <+> r)
|
||||
@ -299,6 +319,7 @@ instance Pretty1 Expr where
|
||||
If b t e -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` e]
|
||||
Assign l r -> l <+> ":=" `indent` r
|
||||
List l -> "list" <+> list l
|
||||
ListAccess l ids -> l <.> cat ((("[" <.>) . (<.> "]") . pp) <$> ids)
|
||||
Set l -> "set" <+> list l
|
||||
Tuple l -> tuple l
|
||||
Annot n t -> parens (n <+> ":" `indent` t)
|
||||
@ -314,7 +335,7 @@ instance Pretty1 Expr where
|
||||
ForBox k mv t z b -> "for" <+> k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> z `indent` b
|
||||
WhileLoop f b -> "while" <+> f `indent` b
|
||||
Seq es -> "block {" `indent` block es `above` "}"
|
||||
Lambda ps ty b -> (("function" `indent` ps) `indent` (":" <+> ty)) `indent` b
|
||||
Lambda ps ty b -> (("lam" `indent` ps) `indent` (":" <+> fromMaybe "<unnanotated>" ty)) `indent` "=>" `indent` b
|
||||
MapPatch z bs -> "patch" `indent` z `above` "with" <+> "map" `indent` list bs
|
||||
SetPatch z bs -> "patch" `indent` z `above` "with" <+> "set" `indent` list bs
|
||||
RecordUpd r up -> r `indent` "with" <+> "record" `indent` list up
|
||||
@ -334,6 +355,7 @@ instance Pretty1 Assignment where
|
||||
instance Pretty1 FieldAssignment where
|
||||
pp1 = \case
|
||||
FieldAssignment n e -> n <+> "=" `indent` e
|
||||
Spread n -> "..." <+> n
|
||||
|
||||
instance Pretty1 Constant where
|
||||
pp1 = \case
|
||||
@ -354,6 +376,7 @@ instance Pretty1 Pattern where
|
||||
IsConstant z -> z
|
||||
IsVar name -> name
|
||||
IsCons h t -> h <+> ("#" <+> t)
|
||||
IsAnnot s t -> "(" <+> s <+> ":" <+> t <+> ")"
|
||||
IsWildcard -> "_"
|
||||
IsList l -> list l
|
||||
IsTuple t -> tuple t
|
||||
@ -31,8 +31,8 @@ debounced act = do
|
||||
putMVar i i'
|
||||
readMVar o >>= either throwM return
|
||||
|
||||
test :: IO ([Int] -> IO Int)
|
||||
test = debounced \s -> do
|
||||
_test :: IO ([Int] -> IO Int)
|
||||
_test = debounced \s -> do
|
||||
threadDelay 2000000
|
||||
unless (odd (length s)) do
|
||||
error "even"
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
|
||||
{-# language StrictData #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE StrictData, TupleSections #-}
|
||||
|
||||
{- | The input tree from TreeSitter. Doesn't have any pointers to any data
|
||||
from actual tree the TS produced and therefore has no usage limitations.
|
||||
@ -16,45 +16,43 @@ module ParseTree
|
||||
|
||||
-- * Invoke the TreeSitter and get the tree it outputs
|
||||
, toParseTree
|
||||
-- , example
|
||||
, mkRawTreePascal
|
||||
, mkRawTreeReason
|
||||
)
|
||||
where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Map
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable (for)
|
||||
|
||||
import TreeSitter.Parser
|
||||
import TreeSitter.Tree hiding (Tree)
|
||||
import TreeSitter.Language
|
||||
import TreeSitter.Node
|
||||
import Control.Monad ((>=>))
|
||||
import Foreign.C.String (peekCString)
|
||||
import Foreign.Ptr ( Ptr
|
||||
, nullPtr
|
||||
)
|
||||
import Foreign.Marshal.Alloc (alloca)
|
||||
import Foreign.Marshal.Array (allocaArray)
|
||||
import Foreign.Storable ( peek
|
||||
, peekElemOff
|
||||
, poke
|
||||
)
|
||||
import Control.Monad ((>=>))
|
||||
import Foreign.Ptr (Ptr, nullPtr)
|
||||
import Foreign.Storable (peek, peekElemOff, poke)
|
||||
import TreeSitter.Language
|
||||
import TreeSitter.Node
|
||||
import TreeSitter.Parser
|
||||
import TreeSitter.Tree hiding (Tree)
|
||||
|
||||
import System.FilePath (takeFileName)
|
||||
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
import Duplo.Pretty
|
||||
import Duplo.Pretty as PP
|
||||
import Duplo.Tree
|
||||
|
||||
import Range
|
||||
import Product
|
||||
import Debouncer
|
||||
import Product
|
||||
import Range
|
||||
|
||||
foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language
|
||||
foreign import ccall unsafe tree_sitter_ReasonLigo :: Ptr Language
|
||||
|
||||
data Source
|
||||
= Path { srcPath :: FilePath }
|
||||
@ -73,10 +71,27 @@ type RawInfo = Product [Range, Text]
|
||||
instance {-# OVERLAPS #-} Modifies RawInfo where
|
||||
ascribe (r :> n :> _) d = color 3 (pp n) <+> pp r `indent` pp d
|
||||
|
||||
data TreeKind
|
||||
= Error
|
||||
| Comment
|
||||
| Field Text
|
||||
deriving stock (Eq, Ord)
|
||||
|
||||
-- TODO: move and refactor
|
||||
instance (Pretty k, Pretty v) => Pretty (Map k v) where
|
||||
pp = pp . fmap snd . toList
|
||||
|
||||
instance Pretty TreeKind where
|
||||
pp = \case
|
||||
Error -> "error"
|
||||
Comment -> "comment"
|
||||
Field t -> "field (" PP.<.> pp t PP.<.> ")"
|
||||
|
||||
-- | The tree tree-sitter produces.
|
||||
data ParseTree self = ParseTree
|
||||
{ ptName :: Text -- ^ Name of the node.
|
||||
, ptChildren :: [self] -- ^ Subtrees.
|
||||
-- , ptChildren :: Map TreeKind self -- ^ Subtrees.
|
||||
, ptSource :: ~Text -- ^ Range of the node.
|
||||
}
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
@ -90,13 +105,20 @@ instance Pretty1 ParseTree where
|
||||
(pp forest)
|
||||
)
|
||||
|
||||
mkRawTreePascal :: Source -> IO RawTree
|
||||
mkRawTreePascal = toParseTree tree_sitter_PascaLigo
|
||||
|
||||
mkRawTreeReason :: Source -> IO RawTree
|
||||
mkRawTreeReason = toParseTree tree_sitter_ReasonLigo
|
||||
|
||||
-- | Feed file contents into PascaLIGO grammar recogniser.
|
||||
toParseTree :: Source -> IO RawTree
|
||||
toParseTree = unsafePerformIO $ debounced inner
|
||||
toParseTree :: Ptr Language -> Source -> IO RawTree
|
||||
toParseTree language = unsafePerformIO $ debounced inner
|
||||
where
|
||||
inner fin = do
|
||||
parser <- ts_parser_new
|
||||
True <- ts_parser_set_language parser tree_sitter_PascaLigo
|
||||
-- True <- ts_parser_set_language parser tree_sitter_PascaLigo
|
||||
True <- ts_parser_set_language parser language
|
||||
|
||||
src <- srcToBytestring fin
|
||||
|
||||
@ -108,11 +130,11 @@ toParseTree = unsafePerformIO $ debounced inner
|
||||
go :: ByteString -> Node -> IO RawTree
|
||||
go src node = do
|
||||
let count = fromIntegral $ nodeChildCount node
|
||||
allocaArray count \children -> do
|
||||
alloca \tsNodePtr -> do
|
||||
allocaArray count $ \children -> do
|
||||
alloca $ \tsNodePtr -> do
|
||||
poke tsNodePtr $ nodeTSNode node
|
||||
ts_node_copy_child_nodes tsNodePtr children
|
||||
nodes <- for [0.. count - 1] \i -> do
|
||||
nodes <- for [0.. count - 1] $ \i -> do
|
||||
peekElemOff children i
|
||||
|
||||
trees <- for nodes \node' -> do
|
||||
@ -148,6 +170,7 @@ toParseTree = unsafePerformIO $ debounced inner
|
||||
|
||||
return $ make (range :> "" :> Nil, ParseTree
|
||||
{ ptName = Text.pack ty
|
||||
-- , ptChildren = fromList . fmap (Comment,) $ trees -- TODO
|
||||
, ptChildren = trees
|
||||
, ptSource = cutOut range src
|
||||
})
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Parser where
|
||||
|
||||
@ -17,8 +18,6 @@ import ParseTree
|
||||
import Range
|
||||
import Product
|
||||
|
||||
-- import Dsebug.Trace
|
||||
|
||||
{-
|
||||
Comment grabber has 2 buffers: 1 and 2.
|
||||
|
||||
@ -49,7 +48,7 @@ instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where
|
||||
tell $ fmap (\t -> (r, Err t)) errs
|
||||
|
||||
after _ _ = do
|
||||
modify \(_, y) -> (y, [])
|
||||
modify $ \(_, y) -> (y, [])
|
||||
|
||||
grabComments :: ParserM [Text]
|
||||
grabComments = do
|
||||
@ -109,7 +108,7 @@ instance Pretty ShowRange where
|
||||
pp N = "Nah"
|
||||
|
||||
type Info = Product [[Text], Range, ShowRange]
|
||||
type PreInfo = Product [Range, ShowRange]
|
||||
-- type PreInfo = Product [Range, ShowRange]
|
||||
|
||||
instance
|
||||
( Contains Range xs
|
||||
|
||||
@ -2,10 +2,11 @@
|
||||
{- | Continious location inside the source and utilities.
|
||||
-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Range
|
||||
( Range(..)
|
||||
, HasRange(..)
|
||||
, diffRange
|
||||
, cutOut
|
||||
, point
|
||||
)
|
||||
@ -33,10 +34,6 @@ data Range = Range
|
||||
deriving (Show) via PP Range
|
||||
deriving stock (Ord)
|
||||
|
||||
-- | TODO: Ugh. Purge it.
|
||||
diffRange :: Range -> Range -> Range
|
||||
diffRange (Range ws wf f) (Range ps _ _) = Range (max ws ps) wf f
|
||||
|
||||
instance Pretty Range where
|
||||
pp (Range (ll, lc, _) (rl, rc, _) f) =
|
||||
color 2 do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user