Core.hs

{-# 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 (Eq, Ord, 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 (Eq, Ord, Show, Enum, Bounded)

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

makeLenses ''ParserConfig

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

-- | Miscellaneous state relating to parsing whitespace + comments
data WSState = WS
  { _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).
  , _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.
  , _comments :: Seq Comment
  -- ^ The actual sequence of comments, in the order they were encountered
  }

makeLenses ''WSState

initWSState :: WSState
initWSState = WS {_freshLine = True, _preWSLoc = 0, _comments = 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 = runParser' defaultParserConfig

-- | Like 'runParser', but allow configuring with an arbitrary
--   'ParserConfig'.
runParser' :: ParserConfig -> Parser a -> Text -> Either ParserError (a, Seq Comment)
runParser' cfg p t =
  (\pt -> parse pt "" t)
    . fmap (second (^. comments))
    . flip runStateT initWSState
    . flip runReaderT cfg
    $ 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 loc p s =
  either (fail . errorBundlePretty) (return . fst)
    . snd
    . flip MP.runParser' initState
    . flip runStateT initWSState
    . flip runReaderT defaultParserConfig {_antiquoting = AllowAntiquoting}
    $ p
 where
  file = TH.loc_filename loc
  (line, col) = TH.loc_start loc
  initState :: State Text Void
  initState =
    (initialState file (from s))
      { statePosState =
          (initialPosState file (from s))
            { pstateSourcePos = SourcePos file (mkPos line) (mkPos col)
            }
      }