-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- A few utilities for use in conjunction with the parser.
module Swarm.Language.Parser.Util (
  fully,
  fullyMaybe,
  showShortError,
  showErrorPos,
  getLocRange,
) where

import Data.List.NonEmpty qualified as NE
import Data.Text (Text)
import Data.Text qualified as T
import Swarm.Language.Parser.Core (ParserError)
import Text.Megaparsec
import Text.Megaparsec.Pos qualified as Pos
import Witch (from)

-- | Run a parser "fully", consuming leading whitespace and ensuring
--   that the parser extends all the way to eof.
fully :: (MonadParsec e s f) => f () -> f a -> f a
fully :: forall e s (f :: * -> *) a. MonadParsec e s f => f () -> f a -> f a
fully f ()
sc f a
p = f ()
sc f () -> f a -> f a
forall a b. f a -> f b -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
p f a -> f () -> f a
forall a b. f a -> f b -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* f ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

-- | Run a parser "fully", consuming leading whitespace (including the
--   possibility that the input is nothing but whitespace) and
--   ensuring that the parser extends all the way to eof.
fullyMaybe :: (MonadParsec e s f) => f () -> f a -> f (Maybe a)
fullyMaybe :: forall e s (f :: * -> *) a.
MonadParsec e s f =>
f () -> f a -> f (Maybe a)
fullyMaybe f ()
sc = f () -> f (Maybe a) -> f (Maybe a)
forall e s (f :: * -> *) a. MonadParsec e s f => f () -> f a -> f a
fully f ()
sc (f (Maybe a) -> f (Maybe a))
-> (f a -> f (Maybe a)) -> f a -> f (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> f (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional

-- | A utility for converting a 'ParserError' into a one line message:
--   @<line-nr>: <error-msg>@
showShortError :: ParserError -> String
showShortError :: ParserError -> String
showShortError ParserError
pe = Int -> String
forall a. Show a => a -> String
show (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall source target. From source target => source -> target
from Text
msg
 where
  ((Int
line, Int
_), (Int, Int)
_, Text
msg) = ParserError -> ((Int, Int), (Int, Int), Text)
showErrorPos ParserError
pe

-- | A utility for converting a 'ParserError' into a range and error message.
showErrorPos :: ParserError -> ((Int, Int), (Int, Int), Text)
showErrorPos :: ParserError -> ((Int, Int), (Int, Int), Text)
showErrorPos (ParseErrorBundle NonEmpty (ParseError Text Void)
errs PosState Text
sourcePS) = ((Int, Int) -> (Int, Int)
forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b)
minusOne (Int, Int)
start, (Int, Int) -> (Int, Int)
forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b)
minusOne (Int, Int)
end, String -> Text
forall source target. From source target => source -> target
from String
msg)
 where
  -- convert megaparsec source pos to starts at 0
  minusOne :: (a, b) -> (a, b)
minusOne (a
x, b
y) = (a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
1, b
y b -> b -> b
forall a. Num a => a -> a -> a
- b
1)

  -- get the first error position (ps) and line content (str)
  err :: ParseError Text Void
err = NonEmpty (ParseError Text Void) -> ParseError Text Void
forall a. NonEmpty a -> a
NE.head NonEmpty (ParseError Text Void)
errs
  offset :: Int
offset = case ParseError Text Void
err of
    TrivialError Int
x Maybe (ErrorItem (Token Text))
_ Set (ErrorItem (Token Text))
_ -> Int
x
    FancyError Int
x Set (ErrorFancy Void)
_ -> Int
x
  (Maybe String
str, PosState Text
ps) = Int -> PosState Text -> (Maybe String, PosState Text)
forall s.
TraversableStream s =>
Int -> PosState s -> (Maybe String, PosState s)
reachOffset Int
offset PosState Text
sourcePS
  msg :: String
msg = ParseError Text Void -> String
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> String
parseErrorTextPretty ParseError Text Void
err

  -- extract the error starting position
  start :: (Int, Int)
start@(Int
line, Int
col) = PosState Text -> (Int, Int)
forall a. PosState a -> (Int, Int)
getLineCol PosState Text
ps

  -- compute the ending position based on the word at starting position
  wordlength :: Int
wordlength = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (String -> (String, String))
-> (String -> String) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
col (String -> (String, String))
-> Maybe String -> Maybe (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
str of
    Just (String
word, String
_) -> String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
word Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    Maybe (String, String)
_ -> Int
0
  end :: (Int, Int)
end = (Int
line, Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wordlength)

getLineCol :: PosState a -> (Int, Int)
getLineCol :: forall a. PosState a -> (Int, Int)
getLineCol PosState a
ps = (Int
line, Int
col)
 where
  line :: Int
line = Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine (SourcePos -> Pos) -> SourcePos -> Pos
forall a b. (a -> b) -> a -> b
$ PosState a -> SourcePos
forall s. PosState s -> SourcePos
pstateSourcePos PosState a
ps
  col :: Int
col = Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn (SourcePos -> Pos) -> SourcePos -> Pos
forall a b. (a -> b) -> a -> b
$ PosState a -> SourcePos
forall s. PosState s -> SourcePos
pstateSourcePos PosState a
ps

-- | Given a text, convert a range expressed as indices into the
--   text value to a range expressed in terms of (line number, column
--   number) pairs.
getLocRange :: Text -> (Int, Int) -> ((Int, Int), (Int, Int))
getLocRange :: Text -> (Int, Int) -> ((Int, Int), (Int, Int))
getLocRange Text
code (Int
locStart, Int
locEnd) = ((Int, Int)
start, (Int, Int)
end)
 where
  start :: (Int, Int)
start = Int -> (Int, Int)
getLocPos Int
locStart
  end :: (Int, Int)
end = Int -> (Int, Int)
getLocPos (Int -> Int
dropWhiteSpace Int
locEnd)

  -- remove trailing whitespace that got included by the lexer
  dropWhiteSpace :: Int -> Int
dropWhiteSpace Int
offset
    | Int -> Bool
isWhiteSpace Int
offset = Int -> Int
dropWhiteSpace (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    | Bool
otherwise = Int
offset
  isWhiteSpace :: Int -> Bool
isWhiteSpace Int
offset =
    -- Megaparsec offset needs to be (-1) to start at 0
    HasCallStack => Text -> Int -> Char
Text -> Int -> Char
T.index Text
code (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
' ', Char
'\n', Char
'\r', Char
'\t']

  -- using megaparsec offset facility, compute the line/col
  getLocPos :: Int -> (Int, Int)
getLocPos Int
offset =
    let sourcePS :: PosState Text
sourcePS =
          PosState
            { pstateInput :: Text
pstateInput = Text
code
            , pstateOffset :: Int
pstateOffset = Int
0
            , pstateSourcePos :: SourcePos
pstateSourcePos = String -> SourcePos
Pos.initialPos String
""
            , pstateTabWidth :: Pos
pstateTabWidth = Pos
Pos.defaultTabWidth
            , pstateLinePrefix :: String
pstateLinePrefix = String
""
            }
        (Maybe String
_, PosState Text
ps) = Int -> PosState Text -> (Maybe String, PosState Text)
forall s.
TraversableStream s =>
Int -> PosState s -> (Maybe String, PosState s)
reachOffset Int
offset PosState Text
sourcePS
     in PosState Text -> (Int, Int)
forall a. PosState a -> (Int, Int)
getLineCol PosState Text
ps