{- |
  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

    -- * Error
  , die

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

    -- * Debug
  , dump

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

import Control.Monad.State
import Control.Monad.Writer hiding (Product)
import Control.Monad.Except
import Control.Monad.Identity

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

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?
--
newtype Parser a = Parser
  { unParser
      :: WriterT [Error ASTInfo]        -- Early I though to report errors that way.
      (  StateT  (ParseForest, [Text])  -- Current forest to recognise + comments.
      (  ExceptT (Error ASTInfo)        -- Backtracking. Change `Error` to `()`?
      (  Identity )))                   -- I forgot why. `#include`? Debug via `print`?
         a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadState   (ParseForest, [Text])
    , MonadWriter [Error ASTInfo]
    , MonadError  (Error ASTInfo)
    )

-- | 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 . fst) <&> \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
  (st@Forest {pfGrove, pfRange}, comms) <- get
  case pfGrove of
    [] -> die msg
    (_, t) : f -> do
      if "comment" `Text.isSuffixOf` ptName t
      then do
        (st', comms') <- get
        put (st', ptSource t : comms')
        takeNext msg
      else do
        put
          ( st
            { pfRange = diffRange pfRange (ptRange t)
            , pfGrove = f
            }
          , comms
          )
        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
  grove <- gets (pfGrove . fst)
  case grove of
    (name', t) : _
      | name == name' -> do
        sandbox True t

    _ -> 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}, comments) <- get
      let (errs, new_comments, grove') = delete name grove
      put
        ( Forest
          { pfID    = ptID
          , pfGrove = [(name, tree)]
          , pfRange = ptRange
          }
        , comments ++ new_comments
        )

      res <- parser

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

      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 = throwError =<< makeError msg

die' ::Text -> ASTInfo -> Parser a
die' msg rng = throwError =<< 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, comms) <- get
    put (ptChildren, comms)
    rest <- gets (pfGrove . fst)
    collectErrors rest
    (_, comms') <- get
    parser <* put (save, comms')
  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)

-- | 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.
--
runParser :: Parser a -> FilePath -> IO (a, [Error ASTInfo])
runParser parser fin = do
  pforest <- toParseTree fin
  let
    res =
             runIdentity
      $      runExceptT
      $ flip runStateT (pforest, [])
      $      runWriterT
      $       unParser
      $ parser

  either (error . show) (return . fst) res

-- | 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
  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
    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

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

-- | 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
  (st, comms) <- get
  put (st, [])
  return comms

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