diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index 91092502f..336280d58 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Parser.hs @@ -48,7 +48,6 @@ typedecl = do vardecl :: Parser (Binding ASTInfo) vardecl = do subtree "var_decl" do - dump ctor Var <*> inside "name" name <*> inside "type" type_ @@ -179,7 +178,6 @@ lambda_expr = do seq_expr = do subtree "block" do - dump ctor Seq <*> do many "statement" do inside "statement" do @@ -229,7 +227,6 @@ skip = do case_action :: Parser (Expr ASTInfo) case_action = do subtree "case_instr" do - dump ctor Case <*> inside "subject" expr <*> many "case" do diff --git a/tools/lsp/squirrel/src/ParseTree.hs b/tools/lsp/squirrel/src/ParseTree.hs index daeebf75f..9e29cd250 100644 --- a/tools/lsp/squirrel/src/ParseTree.hs +++ b/tools/lsp/squirrel/src/ParseTree.hs @@ -39,24 +39,22 @@ foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language getNodeTypesPath :: IO FilePath getNodeTypesPath = getDataFileName "../pascaligo/src/node-types.json" +-- | The tree tree-sitter produces. data ParseTree = ParseTree - { ptID :: Int - , ptName :: Text.Text - , ptRange :: Range - , ptChildren :: ParseForest + { ptID :: Int -- ^ Unique number, for fast comparison. + , ptName :: Text.Text -- ^ Name of the node. + , ptRange :: Range -- ^ Range of the node. + , ptChildren :: ParseForest -- ^ Subtrees. } + deriving (Show) via PP ParseTree +-- ^ The forest we work with. data ParseForest = Forest - { pfID :: Int - , pfGrove :: [(Text.Text, ParseTree)] - , pfRange :: Range + { pfID :: Int -- ^ Unique number for comparison. + , pfGrove :: [(Text.Text, ParseTree)] -- ^ Subtrees. + , pfRange :: Range -- ^ Full range of the forest. } - -instance Show ParseTree where - show = show . pp - -instance Show ParseForest where - show = show . pp + deriving (Show) via PP ParseForest instance Pretty ParseTree where pp (ParseTree _ n r forest) = @@ -75,6 +73,7 @@ instance Pretty ParseForest where then nest 2 $ pp tree else hang (text (Text.unpack field) <> ": ") 2 (pp tree) +-- | Feed file contents into PascaLIGO grammar recogniser. toParseTree :: FilePath -> IO ParseForest toParseTree fin = do parser <- ts_parser_new diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index 05340a3bb..65c03f00f 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/tools/lsp/squirrel/src/Parser.hs @@ -21,24 +21,26 @@ import Pretty import Debug.Trace +-- | Parse error. data Error = Expected - { eMsg :: Text - , eWhole :: Text - , eRange :: Range + { eMsg :: Text -- ^ Description of what was expected. + , eWhole :: Text -- ^ Offending text. + , eRange :: Range -- ^ Location of the error. } - deriving stock (Show) + deriving (Show) via PP Error instance Pretty Error where pp (Expected msg found r) = "░" <> pp msg <> pp r <> "▒" <> pp found <> "▓" +-- | Parser of tree-sitter-made tree. newtype Parser a = Parser { unParser - :: WriterT [Error] - ( ReaderT ParserEnv - ( StateT ParseForest - ( ExceptT Error - ( IO )))) + :: WriterT [Error] -- Early I though to report errors that way. Obs. + ( ReaderT ParserEnv -- Range/Something. + ( StateT ParseForest -- Current forest to recognise. + ( ExceptT Error -- Backtracking. Change `Error` to `()`? + ( IO )))) -- I forgot why. `#include`? Debug via `print`? a } deriving newtype @@ -52,11 +54,13 @@ newtype Parser a = Parser , MonadIO ) +-- | Generate error originating at current location. makeError :: Text -> Parser Error makeError msg = do rng <- getRange makeError' msg rng +-- | Generate error originating at given location. makeError' :: Text -> Range -> Parser Error makeError' msg rng = do rng <- getRange @@ -67,6 +71,7 @@ makeError' msg rng = do , eRange = rng } +-- | Pick next tree in a forest or die with msg. takeNext :: Text -> Parser ParseTree takeNext msg = do st@Forest {pfGrove, pfRange} <- get @@ -79,6 +84,10 @@ takeNext msg = do } return t +-- | Pick a tree with that /field name/ or die with name as msg. +-- +-- Will erase all subtrees with different names on the path! +-- field :: Text -> Parser a -> Parser a field name parser = do grove <- gets pfGrove @@ -107,6 +116,7 @@ field name parser = do , pfRange = if firstOne then diffRange rng ptRange else rng } +-- | Variuos error reports. fallback :: Stubbed a => Text -> Parser a fallback' :: Stubbed a => Text -> Range -> Parser a die :: Text -> Parser a @@ -118,10 +128,13 @@ die msg = throwError =<< makeError msg die' msg rng = throwError =<< makeError' msg rng complain msg rng = tell . pure =<< makeError' msg rng +-- | If a parser fails, return stub with error originating here. stubbed :: Stubbed a => Text -> Parser a -> Parser a stubbed msg parser = do parser <|> fallback msg +-- | The forest must start with tree of that name. Its subtrees become new +-- forest. Otherwise, it dies with name as msg. subtree :: Text -> Parser a -> Parser a subtree msg parser = do ParseTree {ptChildren, ptName} <- takeNext msg @@ -133,6 +146,7 @@ subtree msg parser = do else do die msg +-- | Because `ExceptT` requires error to be `Monoid` for `Alternative`. (<|>) :: Parser a -> Parser a -> Parser a Parser l <|> Parser r = Parser (l `catchError` const r) @@ -142,6 +156,10 @@ select = foldl1 (<|>) optional :: Parser a -> Parser (Maybe a) optional p = fmap Just p <|> return Nothing +-- | Custom `Alternative.many`. +-- +-- TODO: remove msg. +-- many :: Text -> Parser a -> Parser [a] many msg p = many' where @@ -155,6 +173,10 @@ many msg p = many' else do return [x] +-- | Custom `Alternative.some`. +-- +-- TODO: remove msg. +-- some :: Text -> Parser a -> Parser [a] some msg p = some' where @@ -168,12 +190,20 @@ some msg p = some' else do return [x] +-- | Get UID of current tree. Obsolete. +-- +-- TODO: remove. +-- getTreeID :: Parser (Maybe Int) getTreeID = Parser do pfGrove <$> get >>= return . \case [] -> Nothing (_, tree) : _ -> Just (ptID tree) +-- | Assert the parser consumes input. Obsolete. +-- +-- TODO: remove. +-- productive :: Parser a -> Parser (a, Bool) productive p = do was <- getTreeID @@ -181,19 +211,33 @@ productive p = do now <- getTreeID return (res, was /= now) +-- | The `not <$> eos`. Obsolete. +-- +-- TODO: remove. +-- hasPossibleInput :: Parser () hasPossibleInput = do yes <- gets (not . null . pfGrove) unless yes do die "something" +-- | The source of file being parsed. BS, because tree-sitter has offsets +-- in /bytes/. data ParserEnv = ParserEnv { peSource :: ByteString } +-- | Debug print via IO. Obsolete. +-- +-- TODO: remove. Also, remove IO from Parser tf stack. +-- puts :: MonadIO m => Show a => a -> m () puts = liftIO . print +-- | Run parser on given file. +-- +-- TODO: invent /proper/ 'ERROR'-node collector. +-- runParser :: Parser a -> FilePath -> IO (a, [Error]) runParser (Parser parser) fin = do pforest <- toParseTree fin @@ -207,6 +251,7 @@ runParser (Parser parser) fin = do either (error . show) (return . fst) res +-- | Run parser on given file and pretty-print stuff. debugParser :: Parser a -> FilePath -> IO a debugParser parser fin = do (res, errs) <- runParser parser fin @@ -216,6 +261,7 @@ debugParser parser fin = do putStrLn "Result:" return res +-- | Consume next tree if it has give name. Or die. token :: Text -> Parser Text token node = do tree@ParseTree {ptName, ptRange} <- takeNext node @@ -226,28 +272,33 @@ token node = do else do die' node ptRange +-- | Consume next tree, return its textual representation. anything :: Parser Text anything = do tree <- takeNext "anything" cutOut $ ptRange tree +-- | TODO: remove, b/c obsolete. consume :: Text -> Parser () consume node = do ParseTree {ptName, ptRange} <- takeNext node when (ptName /= node) do complain node ptRange +-- | TODO: remove, its literally is `void . token`. consumeOrDie :: Text -> Parser () consumeOrDie node = do ParseTree {ptName, ptRange} <- takeNext node when (ptName /= node) do die' node ptRange +-- | Extract textual representation of given range. cutOut :: Range -> Parser Text cutOut (Range (_, _, s) (_, _, f)) = do bs <- asks peSource return $ decodeUtf8 $ ByteString.take (f - s) (ByteString.drop s bs) +-- | Get range of current tree or forest before the parser was run. range :: Parser a -> Parser (a, Range) range parser = get >>= \case @@ -259,9 +310,14 @@ range parser = a <- parser return (a, pfRange) +-- | Get current range. getRange :: Parser Range getRange = snd <$> range (return ()) +-- | Remove all keys until given key is found; remove the latter as well. +-- +-- Notice: this works differently from `Prelude.remove`! +-- delete :: Eq k => k -> [(k, v)] -> [(k, v)] delete _ [] = [] delete k ((k', v) : rest) = @@ -269,6 +325,7 @@ delete k ((k', v) : rest) = then rest else delete k rest +-- | Parser negation. notFollowedBy :: Parser a -> Parser () notFollowedBy parser = do good <- do @@ -280,24 +337,39 @@ notFollowedBy parser = do unless good do die "notFollowedBy" +-- | For types that have a default replacer with an `Error`. class Stubbed a where stub :: Error -> a instance Stubbed Text where stub = pack . show +-- | This is bad, but I had to. +-- +-- TODO: find a way to remove this instance. +-- instance Stubbed [a] where stub _ = [] +-- | `Nothing` would be bad default replacer. instance Stubbed a => Stubbed (Maybe a) where stub = Just . stub +-- | Universal accessor. +-- +-- Usage: +-- +-- > inside "$field:$treename" +-- > inside "$field" +-- > inside ":$treename" -- don't, use "subtree" +-- inside :: Stubbed a => Text -> Parser a -> Parser a inside sig parser = do let (f, st') = Text.breakOn ":" sig let st = Text.drop 1 st' if Text.null f then do + -- The order is important. subtree st do stubbed f do parser @@ -311,13 +383,16 @@ inside sig parser = do subtree st do parser +-- Auto-accumulated information to be fed into AST being build. data ASTInfo = ASTInfo { aiRange :: Range , aiComments :: [Text] } +-- | Equip given constructor with info. ctor :: (ASTInfo -> a) -> Parser a ctor = (<$> (ASTInfo <$> getRange <*> pure [])) +-- | /Actual/ debug pring. dump :: Parser () dump = gets pfGrove >>= traceShowM