ligo/tools/lsp/squirrel/src/Parser.hs

{- |
  The thing that can untangle the mess that TreeSitter produces.

  In presence of serious errors, it /will/ be a mess, anyway.

  The AST you are building must be the @Tree@ in each point.

  I recommend, in your tree-sitter grammar, to add `field("foo", ...)`
  to each sub-rule, that has `$.` in front of it -  in a rule, that doesn't
  start with `_` in its name.

  As a general rule of thumb, make each significant part a separate rule,
  even if it is a keyword. Then, apply previous advice.

  Only make rule start with `_` if it is a pure choice.

  > ('block'
  >   ...
  >   a: <a>
  >   ...
  >   b: <b>
  >   ...)

  ->

  > block = do
  >   subtree "block" do
  >     ranged do
  >       pure Block
  >         <*> inside "a" a
  >         <*> inside "b" b
-}

module Parser
  ( -- * Parser type
    Parser
  , runParser
  , debugParser

    -- * Combinators
  , subtree
  , anything
  , token
  , stubbed
  , getInfo
  , inside
  , restart

    -- * Error
  , die

    -- * Replacement for `Alternative`, because reasons
  , many
  , some
  , (<|>)
  , optional
  , select

    -- * Debug
  , dump

    -- * Comments and ranges
  , ASTInfo(..)
  ) where

import Control.Monad.Writer hiding (Product)
import Control.Monad.State
import Control.Monad.Catch
import qualified Control.Monad.Reader as MTL

import Data.Functor ((<&>))
import Data.Foldable
import Data.IORef
import Data.Text (Text, unpack)
import qualified Data.Text as Text

import System.FilePath

import ParseTree
import Range
import Pretty
import Comment
import Error
import Product

import Debug.Trace

-- | Parser of tree-sitter-made tree.
--
--   TODO: separate state. Polysemy?
--
type Parser =
   WriterT [Error ASTInfo]
  (StateT (Product PList)
   IO)

type PList = [ParseForest, [Text], FilePath]

-- | Auto-accumulated information to be put into AST being build.
type ASTInfo = Product [Range, [Text]]

runParser
  :: Parser a
  -> FilePath
  -> IO (a, [Error ASTInfo])
runParser parser fin = do
  pforest <- toParseTree fin

  let dir = takeDirectory fin

  runWriterT parser `evalStateT` Cons pforest (Cons [] (Cons dir Nil))

restart :: Parser a -> FilePath -> Parser a
restart p fin = do
  dir <- get' @FilePath
  (a, errs) <- liftIO do runParser p (dir </> fin)
  tell errs
  return a

get' :: forall x. Contains x PList => Parser x
get' = gets getElem

gets' :: forall x a. Contains x PList => (x -> a) -> Parser a
gets' f = gets (f . getElem)

put' :: forall x. Contains x PList => x -> Parser ()
put' x = modify $ modElem $ const x

mod' :: forall x. Contains x PList => (x -> x) -> Parser ()
mod' = modify . modElem

-- | Generate error originating at current location.
makeError :: Text -> Parser (Error ASTInfo)
makeError msg = do
  rng <- getInfo
  makeError' msg rng

-- | Generate error originating at given location.
makeError' :: Text -> info -> Parser (Error info)
makeError' msg i = do
  src <- gets' pfGrove <&> \case
    []                     -> ""
    (,) _ ParseTree { ptSource } : _ -> ptSource
  return Expected
    { eMsg   = msg
    , eWhole = src
    , eInfo  = i
    }

-- | Pick next tree in a forest or die with msg.
takeNext :: Text -> Parser ParseTree
takeNext msg = do
  gets' pfGrove >>= \case
    [] -> die msg
    (_, t) : f -> do
      if "comment" `Text.isSuffixOf` ptName t
      then do
        mod' (ptSource t :)
        takeNext msg
      else do
        mod' \st -> st
          { pfRange = diffRange (pfRange st) (ptRange t)
          , pfGrove = f
          }
        return t

--fields :: Text -> Parser a -> Parser [a]
--fields name parser = do
--  (fs, rest) <- gets $ splitForest name . fst
--  res <- for fs \f -> do
--    put f
--    parser
--
--  put rest
--  return res
--
--splitForest :: Text -> ParseForest -> [ParseForest]
--splitForest name = go . pfGrove
--  where
--    go []             acc fs = (fs, acc)
--    go ((tName, tree) : other) acc fs =
--      if tName == name
--      then go other [] (reverse (tree : acc) : fs)
--      else go other (tree : acc) fs

-- | 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
  gets' pfGrove >>= \case
    (name', t) : _
      | name == name' -> do
        sandbox True t

    grove -> do
      case lookup name grove of
        Just tree -> sandbox False tree
        Nothing   -> die name

  where
    sandbox firstOne tree@ParseTree {ptID, ptRange} = do
      st@Forest {pfGrove = grove, pfRange = rng} <- get'
      let (errs, new_comments, grove') = delete name grove
      mod' (++ new_comments)
      put' Forest
        { pfID    = ptID
        , pfGrove = [(name, tree)]
        , pfRange = ptRange
        }

      res <- parser

      put' st
        { pfGrove = grove'
        , pfRange = if firstOne then diffRange rng ptRange else rng
        }

      put' @[Text] []

      for_ errs (tell . pure . unexpected)

      return res

fallback :: Stubbed a ASTInfo => Text -> Parser a
fallback msg = pure . stub =<< makeError msg

-- | Produce "expected ${X}" error at this point.
die :: Text -> Parser a
die msg = throwM =<< makeError msg

die' ::Text -> ASTInfo -> Parser a
die' msg rng = throwM =<< makeError' msg rng

-- | When tree-sitter found something it was unable to process.
unexpected :: ParseTree -> Error ASTInfo
unexpected ParseTree { ptSource, ptRange } =
  Expected "not that" ptSource (Cons ptRange $ Cons [] Nil)

-- | If a parser fails, return stub with error originating here.
stubbed :: Stubbed a ASTInfo => 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
  if ptName == msg
  then do
    save <- get' @ParseForest
    put' ptChildren
    rest <- gets' pfGrove
    collectErrors rest
    parser <* put' save
  else do
    die msg

-- | Because `ExceptT` requires error to be `Monoid` for `Alternative`.
(<|>) :: Parser a -> Parser a -> Parser a
l <|> r = do
  s <- get' @ParseForest
  c <- get' @[Text]
  l `catch` \(e :: Error ASTInfo) -> do
    put' s
    put' c
    r

-- | Custom @foldl1 (<|>)@.
select :: [Parser a] -> Parser a
select = foldl1 (<|>)

-- | Custom @optionMaybe@.
optional :: Parser a -> Parser (Maybe a)
optional p = fmap Just p <|> return Nothing

-- | Custom `Alternative.many`.
--
--   TODO: remove, replace with `fields` combinator.
--
many :: Parser a -> Parser [a]
many p = many'
  where
    many' = some' <|> pure []
    some' = do
      x <- p
      xs <- many'
      return (x : xs)

-- | Custom `Alternative.some`.
--
some :: Parser a -> Parser [a]
some p = some'
  where
    many' = some' <|> pure []
    some' = do
      x <- p
      xs <- many'
      return (x : xs)

-- | Run parser on given file and pretty-print stuff.
--
debugParser :: Show a => Parser a -> FilePath -> IO ()
debugParser parser fin = do
  (res, errs) <- runParser parser fin
  putStrLn "Result:"
  print res
  MTL.unless (null errs) do
    putStrLn ""
    putStrLn "Errors:"
    for_ errs (print . nest 2 . pp)

-- | Consume next tree if it has the given name. Or die.
token :: Text -> Parser Text
token node = do
  i <- getInfo
  ParseTree {ptName, ptSource} <- takeNext node
  if ptName == node
  then return ptSource
  else die' node i

-- | Consume next tree, return its textual representation.
anything :: Parser Text
anything = do
  tree <- takeNext "anything"
  return $ ptSource tree

-- | Get range of the current tree (or forest) before the parser was run.
range :: Parser a -> Parser (a, Range)
range parser =
  get' >>= \case
    Forest {pfGrove = [(,) _ ParseTree {ptRange}]} -> do
      a <- parser
      return (a, ptRange)

    Forest {pfRange} -> do
      a <- parser
      return (a, pfRange)

-- | Get current range.
currentRange :: Parser Range
currentRange = snd <$> range (return ())

-- | Remove all keys until given key is found; remove the latter as well.
--
--   Also returns all ERROR-nodes.
--
--   TODO: rename.
--
--   Notice: this works differently from `Prelude.remove`!
--
delete :: Text -> [(Text, ParseTree)] -> ([ParseTree], [Text], [(Text, ParseTree)])
delete _ [] = ([], [], [])
delete k ((k', v) : rest) =
  if k == k'
  then (addIfError v [], addIfComment v [], rest)
  else (addIfError v vs, addIfComment v cs, remains)
  where
    (vs, cs, remains) = delete k rest
    addIfError v' =
      if ptName v' == "ERROR"
      then (:) v'
      else id

    addIfComment v' =
      if "comment" `Text.isSuffixOf` ptName v'
      then (ptSource v' :)
      else id

-- | Report all ERRORs from the list.
collectErrors :: [(Text, ParseTree)] -> Parser ()
collectErrors vs =
  for_ vs \(_, v) -> do
    MTL.when (ptName v == "ERROR") do
      tell [unexpected v]

-- | Universal accessor.
--
--   Usage:
--
--   > inside "$field:$treename"
--   > inside "$field"
--   > inside ":$treename" -- don't, use "subtree"
--
inside :: Stubbed a ASTInfo => 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
  else do
    field f do
      stubbed f do
        if Text.null st
        then do
          parser
        else do
          subtree st do
            parser

-- | Equip given constructor with info.
getInfo :: Parser ASTInfo
getInfo = Cons <$> currentRange <*> do Cons <$> grabComments <*> pure Nil

-- | Take the accumulated comments, clean the accumulator.
grabComments :: Parser [Text]
grabComments = do
  comms <- get'
  mod' @[Text] $ const []
  return comms

-- | /Actual/ debug pring.
dump :: Parser ()
dump = gets' pfGrove >>= traceShowM