{-# LANGUAGE TemplateHaskell #-}
module Swarm.Language.Parser.Core (
Antiquoting (..),
LanguageVersion (..),
ParserConfig,
defaultParserConfig,
antiquoting,
languageVersion,
WSState (..),
freshLine,
preWSLoc,
comments,
Parser,
ParserError,
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)
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)
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)
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
}
data WSState = WS
{ WSState -> Bool
_freshLine :: Bool
, WSState -> Int
_preWSLoc :: Int
, :: Seq Comment
}
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}
type Parser = ReaderT ParserConfig (StateT WSState (Parsec Void Text))
type ParserError = ParseErrorBundle Text Void
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
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
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)
}
}