{-# LANGUAGE TemplateHaskell #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Core data type definitions and utilities for the Swarm language
-- parser.
module Swarm.Language.Parser.Core (
  -- * Parser configuration
  Antiquoting (..),
  LanguageVersion (..),
  ParserConfig,
  defaultParserConfig,
  antiquoting,
  languageVersion,

  -- * Comment parsing state
  WSState (..),
  freshLine,
  preWSLoc,
  comments,

  -- * Parser type
  Parser,
  ParserError,

  -- ** Running
  runParser,
  runParser',
  runParserTH,
) where

import Control.Lens (makeLenses, (^.))
import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.State (StateT, runStateT)
import Data.Bifunctor (second)
import Data.Sequence (Seq)
import Data.Sequence qualified as Seq
import Data.Text (Text)
import Data.Void (Void)
import Language.Haskell.TH qualified as TH
import Swarm.Language.Syntax (Comment)
import Text.Megaparsec hiding (runParser, runParser')
import Text.Megaparsec qualified as MP
import Text.Megaparsec.State (initialPosState, initialState)
import Witch (from)

------------------------------------------------------------
-- Custom parser state

-- | When parsing a term using a quasiquoter (i.e. something in the
--   Swarm source code that will be parsed at compile time), we want
--   to allow antiquoting, i.e. writing something like $x to refer to
--   an existing Haskell variable.  But when parsing a term entered by
--   the user at the REPL, we do not want to allow this syntax.
data Antiquoting = AllowAntiquoting | DisallowAntiquoting
  deriving (Antiquoting -> Antiquoting -> Bool
(Antiquoting -> Antiquoting -> Bool)
-> (Antiquoting -> Antiquoting -> Bool) -> Eq Antiquoting
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Antiquoting -> Antiquoting -> Bool
== :: Antiquoting -> Antiquoting -> Bool
$c/= :: Antiquoting -> Antiquoting -> Bool
/= :: Antiquoting -> Antiquoting -> Bool
Eq, Eq Antiquoting
Eq Antiquoting =>
(Antiquoting -> Antiquoting -> Ordering)
-> (Antiquoting -> Antiquoting -> Bool)
-> (Antiquoting -> Antiquoting -> Bool)
-> (Antiquoting -> Antiquoting -> Bool)
-> (Antiquoting -> Antiquoting -> Bool)
-> (Antiquoting -> Antiquoting -> Antiquoting)
-> (Antiquoting -> Antiquoting -> Antiquoting)
-> Ord Antiquoting
Antiquoting -> Antiquoting -> Bool
Antiquoting -> Antiquoting -> Ordering
Antiquoting -> Antiquoting -> Antiquoting
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Antiquoting -> Antiquoting -> Ordering
compare :: Antiquoting -> Antiquoting -> Ordering
$c< :: Antiquoting -> Antiquoting -> Bool
< :: Antiquoting -> Antiquoting -> Bool
$c<= :: Antiquoting -> Antiquoting -> Bool
<= :: Antiquoting -> Antiquoting -> Bool
$c> :: Antiquoting -> Antiquoting -> Bool
> :: Antiquoting -> Antiquoting -> Bool
$c>= :: Antiquoting -> Antiquoting -> Bool
>= :: Antiquoting -> Antiquoting -> Bool
$cmax :: Antiquoting -> Antiquoting -> Antiquoting
max :: Antiquoting -> Antiquoting -> Antiquoting
$cmin :: Antiquoting -> Antiquoting -> Antiquoting
min :: Antiquoting -> Antiquoting -> Antiquoting
Ord, Int -> Antiquoting -> ShowS
[Antiquoting] -> ShowS
Antiquoting -> String
(Int -> Antiquoting -> ShowS)
-> (Antiquoting -> String)
-> ([Antiquoting] -> ShowS)
-> Show Antiquoting
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Antiquoting -> ShowS
showsPrec :: Int -> Antiquoting -> ShowS
$cshow :: Antiquoting -> String
show :: Antiquoting -> String
$cshowList :: [Antiquoting] -> ShowS
showList :: [Antiquoting] -> ShowS
Show)

-- | Which version of the Swarm language are we parsing?  As a general
--   rule, we want to support one older version in addition to the
--   current version, to allow for upgrading code via @swarm format@.
data LanguageVersion = SwarmLang0_6 | SwarmLangLatest
  deriving (LanguageVersion -> LanguageVersion -> Bool
(LanguageVersion -> LanguageVersion -> Bool)
-> (LanguageVersion -> LanguageVersion -> Bool)
-> Eq LanguageVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LanguageVersion -> LanguageVersion -> Bool
== :: LanguageVersion -> LanguageVersion -> Bool
$c/= :: LanguageVersion -> LanguageVersion -> Bool
/= :: LanguageVersion -> LanguageVersion -> Bool
Eq, Eq LanguageVersion
Eq LanguageVersion =>
(LanguageVersion -> LanguageVersion -> Ordering)
-> (LanguageVersion -> LanguageVersion -> Bool)
-> (LanguageVersion -> LanguageVersion -> Bool)
-> (LanguageVersion -> LanguageVersion -> Bool)
-> (LanguageVersion -> LanguageVersion -> Bool)
-> (LanguageVersion -> LanguageVersion -> LanguageVersion)
-> (LanguageVersion -> LanguageVersion -> LanguageVersion)
-> Ord LanguageVersion
LanguageVersion -> LanguageVersion -> Bool
LanguageVersion -> LanguageVersion -> Ordering
LanguageVersion -> LanguageVersion -> LanguageVersion
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LanguageVersion -> LanguageVersion -> Ordering
compare :: LanguageVersion -> LanguageVersion -> Ordering
$c< :: LanguageVersion -> LanguageVersion -> Bool
< :: LanguageVersion -> LanguageVersion -> Bool
$c<= :: LanguageVersion -> LanguageVersion -> Bool
<= :: LanguageVersion -> LanguageVersion -> Bool
$c> :: LanguageVersion -> LanguageVersion -> Bool
> :: LanguageVersion -> LanguageVersion -> Bool
$c>= :: LanguageVersion -> LanguageVersion -> Bool
>= :: LanguageVersion -> LanguageVersion -> Bool
$cmax :: LanguageVersion -> LanguageVersion -> LanguageVersion
max :: LanguageVersion -> LanguageVersion -> LanguageVersion
$cmin :: LanguageVersion -> LanguageVersion -> LanguageVersion
min :: LanguageVersion -> LanguageVersion -> LanguageVersion
Ord, Int -> LanguageVersion -> ShowS
[LanguageVersion] -> ShowS
LanguageVersion -> String
(Int -> LanguageVersion -> ShowS)
-> (LanguageVersion -> String)
-> ([LanguageVersion] -> ShowS)
-> Show LanguageVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LanguageVersion -> ShowS
showsPrec :: Int -> LanguageVersion -> ShowS
$cshow :: LanguageVersion -> String
show :: LanguageVersion -> String
$cshowList :: [LanguageVersion] -> ShowS
showList :: [LanguageVersion] -> ShowS
Show, Int -> LanguageVersion
LanguageVersion -> Int
LanguageVersion -> [LanguageVersion]
LanguageVersion -> LanguageVersion
LanguageVersion -> LanguageVersion -> [LanguageVersion]
LanguageVersion
-> LanguageVersion -> LanguageVersion -> [LanguageVersion]
(LanguageVersion -> LanguageVersion)
-> (LanguageVersion -> LanguageVersion)
-> (Int -> LanguageVersion)
-> (LanguageVersion -> Int)
-> (LanguageVersion -> [LanguageVersion])
-> (LanguageVersion -> LanguageVersion -> [LanguageVersion])
-> (LanguageVersion -> LanguageVersion -> [LanguageVersion])
-> (LanguageVersion
    -> LanguageVersion -> LanguageVersion -> [LanguageVersion])
-> Enum LanguageVersion
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: LanguageVersion -> LanguageVersion
succ :: LanguageVersion -> LanguageVersion
$cpred :: LanguageVersion -> LanguageVersion
pred :: LanguageVersion -> LanguageVersion
$ctoEnum :: Int -> LanguageVersion
toEnum :: Int -> LanguageVersion
$cfromEnum :: LanguageVersion -> Int
fromEnum :: LanguageVersion -> Int
$cenumFrom :: LanguageVersion -> [LanguageVersion]
enumFrom :: LanguageVersion -> [LanguageVersion]
$cenumFromThen :: LanguageVersion -> LanguageVersion -> [LanguageVersion]
enumFromThen :: LanguageVersion -> LanguageVersion -> [LanguageVersion]
$cenumFromTo :: LanguageVersion -> LanguageVersion -> [LanguageVersion]
enumFromTo :: LanguageVersion -> LanguageVersion -> [LanguageVersion]
$cenumFromThenTo :: LanguageVersion
-> LanguageVersion -> LanguageVersion -> [LanguageVersion]
enumFromThenTo :: LanguageVersion
-> LanguageVersion -> LanguageVersion -> [LanguageVersion]
Enum, LanguageVersion
LanguageVersion -> LanguageVersion -> Bounded LanguageVersion
forall a. a -> a -> Bounded a
$cminBound :: LanguageVersion
minBound :: LanguageVersion
$cmaxBound :: LanguageVersion
maxBound :: LanguageVersion
Bounded)

-- | Read-only parser configuration.
data ParserConfig = ParserConfig
  { ParserConfig -> Antiquoting
_antiquoting :: Antiquoting
  , ParserConfig -> LanguageVersion
_languageVersion :: LanguageVersion
  }

makeLenses ''ParserConfig

defaultParserConfig :: ParserConfig
defaultParserConfig :: ParserConfig
defaultParserConfig =
  ParserConfig
    { _antiquoting :: Antiquoting
_antiquoting = Antiquoting
DisallowAntiquoting
    , _languageVersion :: LanguageVersion
_languageVersion = LanguageVersion
SwarmLangLatest
    }

-- | Miscellaneous state relating to parsing whitespace + comments
data WSState = WS
  { WSState -> Bool
_freshLine :: Bool
  -- ^ Are we currently on a (so far) blank line, i.e. have there been
  --   no nontrivial tokens since the most recent newline?  This field
  --   is updated every time we parse a lexeme or symbol (set to
  --   false), or a newline (set to true).
  , WSState -> Int
_preWSLoc :: Int
  -- ^ The last source location before we started consuming
  --   whitespace.  We use this to assign more accurate source spans
  --   to AST nodes, which do *not* include any trailing whitespace.
  , WSState -> Seq Comment
_comments :: Seq Comment
  -- ^ The actual sequence of comments, in the order they were encountered
  }

makeLenses ''WSState

initWSState :: WSState
initWSState :: WSState
initWSState = WS {_freshLine :: Bool
_freshLine = Bool
True, _preWSLoc :: Int
_preWSLoc = Int
0, _comments :: Seq Comment
_comments = Seq Comment
forall a. Seq a
Seq.empty}

------------------------------------------------------------
-- Parser types

type Parser = ReaderT ParserConfig (StateT WSState (Parsec Void Text))

type ParserError = ParseErrorBundle Text Void

------------------------------------------------------------
-- Running parsers

-- | Run a parser on some input text, returning either the result +
--   all collected comments, or a parse error message.
runParser :: Parser a -> Text -> Either ParserError (a, Seq Comment)
runParser :: forall a. Parser a -> Text -> Either ParserError (a, Seq Comment)
runParser = ParserConfig
-> Parser a -> Text -> Either ParserError (a, Seq Comment)
forall a.
ParserConfig
-> Parser a -> Text -> Either ParserError (a, Seq Comment)
runParser' ParserConfig
defaultParserConfig

-- | Like 'runParser', but allow configuring with an arbitrary
--   'ParserConfig'.
runParser' :: ParserConfig -> Parser a -> Text -> Either ParserError (a, Seq Comment)
runParser' :: forall a.
ParserConfig
-> Parser a -> Text -> Either ParserError (a, Seq Comment)
runParser' ParserConfig
cfg Parser a
p Text
t =
  (\Parsec Void Text (a, Seq Comment)
pt -> Parsec Void Text (a, Seq Comment)
-> String -> Text -> Either ParserError (a, Seq Comment)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text (a, Seq Comment)
pt String
"" Text
t)
    (Parsec Void Text (a, Seq Comment)
 -> Either ParserError (a, Seq Comment))
-> (Parser a -> Parsec Void Text (a, Seq Comment))
-> Parser a
-> Either ParserError (a, Seq Comment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, WSState) -> (a, Seq Comment))
-> ParsecT Void Text Identity (a, WSState)
-> Parsec Void Text (a, Seq Comment)
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((WSState -> Seq Comment) -> (a, WSState) -> (a, Seq Comment)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (WSState
-> Getting (Seq Comment) WSState (Seq Comment) -> Seq Comment
forall s a. s -> Getting a s a -> a
^. Getting (Seq Comment) WSState (Seq Comment)
Lens' WSState (Seq Comment)
comments))
    (ParsecT Void Text Identity (a, WSState)
 -> Parsec Void Text (a, Seq Comment))
-> (Parser a -> ParsecT Void Text Identity (a, WSState))
-> Parser a
-> Parsec Void Text (a, Seq Comment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT WSState (ParsecT Void Text Identity) a
 -> WSState -> ParsecT Void Text Identity (a, WSState))
-> WSState
-> StateT WSState (ParsecT Void Text Identity) a
-> ParsecT Void Text Identity (a, WSState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT WSState (ParsecT Void Text Identity) a
-> WSState -> ParsecT Void Text Identity (a, WSState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT WSState
initWSState
    (StateT WSState (ParsecT Void Text Identity) a
 -> ParsecT Void Text Identity (a, WSState))
-> (Parser a -> StateT WSState (ParsecT Void Text Identity) a)
-> Parser a
-> ParsecT Void Text Identity (a, WSState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Parser a
 -> ParserConfig -> StateT WSState (ParsecT Void Text Identity) a)
-> ParserConfig
-> Parser a
-> StateT WSState (ParsecT Void Text Identity) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Parser a
-> ParserConfig -> StateT WSState (ParsecT Void Text Identity) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ParserConfig
cfg
    (Parser a -> Either ParserError (a, Seq Comment))
-> Parser a -> Either ParserError (a, Seq Comment)
forall a b. (a -> b) -> a -> b
$ Parser a
p

-- | A utility for running a parser in an arbitrary 'MonadFail' (which
--   is going to be the TemplateHaskell 'Language.Haskell.TH.Q' monad --- see
--   "Swarm.Language.Parser.QQ"), with a specified source position.
runParserTH :: (Monad m, MonadFail m) => TH.Loc -> Parser a -> String -> m a
runParserTH :: forall (m :: * -> *) a.
(Monad m, MonadFail m) =>
Loc -> Parser a -> String -> m a
runParserTH Loc
loc Parser a
p String
s =
  (ParserError -> m a)
-> ((a, WSState) -> m a) -> Either ParserError (a, WSState) -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> (ParserError -> String) -> ParserError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserError -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) (a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> ((a, WSState) -> a) -> (a, WSState) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, WSState) -> a
forall a b. (a, b) -> a
fst)
    (Either ParserError (a, WSState) -> m a)
-> (Parser a -> Either ParserError (a, WSState)) -> Parser a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State Text Void, Either ParserError (a, WSState))
-> Either ParserError (a, WSState)
forall a b. (a, b) -> b
snd
    ((State Text Void, Either ParserError (a, WSState))
 -> Either ParserError (a, WSState))
-> (Parser a -> (State Text Void, Either ParserError (a, WSState)))
-> Parser a
-> Either ParserError (a, WSState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Parsec Void Text (a, WSState)
 -> State Text Void
 -> (State Text Void, Either ParserError (a, WSState)))
-> State Text Void
-> Parsec Void Text (a, WSState)
-> (State Text Void, Either ParserError (a, WSState))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Parsec Void Text (a, WSState)
-> State Text Void
-> (State Text Void, Either ParserError (a, WSState))
forall e s a.
Parsec e s a
-> State s e -> (State s e, Either (ParseErrorBundle s e) a)
MP.runParser' State Text Void
initState
    (Parsec Void Text (a, WSState)
 -> (State Text Void, Either ParserError (a, WSState)))
-> (Parser a -> Parsec Void Text (a, WSState))
-> Parser a
-> (State Text Void, Either ParserError (a, WSState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT WSState (ParsecT Void Text Identity) a
 -> WSState -> Parsec Void Text (a, WSState))
-> WSState
-> StateT WSState (ParsecT Void Text Identity) a
-> Parsec Void Text (a, WSState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT WSState (ParsecT Void Text Identity) a
-> WSState -> Parsec Void Text (a, WSState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT WSState
initWSState
    (StateT WSState (ParsecT Void Text Identity) a
 -> Parsec Void Text (a, WSState))
-> (Parser a -> StateT WSState (ParsecT Void Text Identity) a)
-> Parser a
-> Parsec Void Text (a, WSState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Parser a
 -> ParserConfig -> StateT WSState (ParsecT Void Text Identity) a)
-> ParserConfig
-> Parser a
-> StateT WSState (ParsecT Void Text Identity) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Parser a
-> ParserConfig -> StateT WSState (ParsecT Void Text Identity) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ParserConfig
defaultParserConfig {_antiquoting = AllowAntiquoting}
    (Parser a -> m a) -> Parser a -> m a
forall a b. (a -> b) -> a -> b
$ Parser a
p
 where
  file :: String
file = Loc -> String
TH.loc_filename Loc
loc
  (Int
line, Int
col) = Loc -> (Int, Int)
TH.loc_start Loc
loc
  initState :: State Text Void
  initState :: State Text Void
initState =
    (String -> Text -> State Text Void
forall s e. String -> s -> State s e
initialState String
file (String -> Text
forall source target. From source target => source -> target
from String
s))
      { statePosState =
          (initialPosState file (from s))
            { pstateSourcePos = SourcePos file (mkPos line) (mkPos col)
            }
      }