diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 973f244fb..65e82d7e9 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -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)) diff --git a/tools/lsp/squirrel/src/AST.hs b/tools/lsp/squirrel/src/AST.hs index d221e316d..11ab94670 100644 --- a/tools/lsp/squirrel/src/AST.hs +++ b/tools/lsp/squirrel/src/AST.hs @@ -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 diff --git a/tools/lsp/squirrel/src/AST/Completion.hs b/tools/lsp/squirrel/src/AST/Completion.hs index cbca3ae10..efcdcf12c 100644 --- a/tools/lsp/squirrel/src/AST/Completion.hs +++ b/tools/lsp/squirrel/src/AST/Completion.hs @@ -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 @@ -65,4 +62,4 @@ fits Nothing _ = True fits (Just c) c' = c == c' catFromType :: ScopedDecl -> Category -catFromType = maybe Variable (either (const Variable) (const Type)) . _sdType \ No newline at end of file +catFromType = maybe Variable (either (const Variable) (const Type)) . _sdType diff --git a/tools/lsp/squirrel/src/AST/Find.hs b/tools/lsp/squirrel/src/AST/Find.hs index 3967127e9..2024f3ce3 100644 --- a/tools/lsp/squirrel/src/AST/Find.hs +++ b/tools/lsp/squirrel/src/AST/Find.hs @@ -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 diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs similarity index 97% rename from tools/lsp/squirrel/src/AST/Parser.hs rename to tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs index a159e3b9b..b2de7bdab 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs @@ -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 @@ -276,4 +271,4 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope return ([] :> r :> Y :> Nil, Err text') _ -> fallthrough - ] + ] \ No newline at end of file diff --git a/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs b/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs new file mode 100644 index 000000000..fc1bab038 --- /dev/null +++ b/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs @@ -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 + ] diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index 2b3406841..c5b0939bc 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/tools/lsp/squirrel/src/AST/Scope.hs @@ -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 \ No newline at end of file +-- instance Scoped a CollectM (LIGO a) Ctor(Contains Range xs, Eq (Product xs), Scoped (Product xs) CollectM (Tree RawLigoList (Product xs)) ReasonExpr) \ No newline at end of file diff --git a/tools/lsp/squirrel/src/AST/Types.hs b/tools/lsp/squirrel/src/AST/Skeleton.hs similarity index 87% rename from tools/lsp/squirrel/src/AST/Types.hs rename to tools/lsp/squirrel/src/AST/Skeleton.hs index 47be3e2cc..ea7704f57 100644 --- a/tools/lsp/squirrel/src/AST/Types.hs +++ b/tools/lsp/squirrel/src/AST/Skeleton.hs @@ -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 "" 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 "" 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 diff --git a/tools/lsp/squirrel/src/Debouncer.hs b/tools/lsp/squirrel/src/Debouncer.hs index 00151d510..6ddb0cde6 100644 --- a/tools/lsp/squirrel/src/Debouncer.hs +++ b/tools/lsp/squirrel/src/Debouncer.hs @@ -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" diff --git a/tools/lsp/squirrel/src/ParseTree.hs b/tools/lsp/squirrel/src/ParseTree.hs index 7cf6f912e..814744070 100644 --- a/tools/lsp/squirrel/src/ParseTree.hs +++ b/tools/lsp/squirrel/src/ParseTree.hs @@ -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 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 Data.Traversable (for) -import TreeSitter.Parser -import TreeSitter.Tree hiding (Tree) +import Control.Monad ((>=>)) +import Foreign.C.String (peekCString) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (peek, peekElemOff, poke) import TreeSitter.Language import TreeSitter.Node -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 TreeSitter.Parser +import TreeSitter.Tree hiding (Tree) -import System.FilePath (takeFileName) +import System.FilePath (takeFileName) import System.IO.Unsafe (unsafePerformIO) -import Duplo.Pretty -import Duplo.Tree +import Duplo.Pretty as PP +import Duplo.Tree -import Range -import Product -import Debouncer +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 }) diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index 8b4fea851..1ec0f2bd8 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/tools/lsp/squirrel/src/Parser.hs @@ -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 diff --git a/tools/lsp/squirrel/src/Range.hs b/tools/lsp/squirrel/src/Range.hs index 2ad149f96..40f6cdd72 100644 --- a/tools/lsp/squirrel/src/Range.hs +++ b/tools/lsp/squirrel/src/Range.hs @@ -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