1
1
mirror of https://github.com/github/semantic.git synced 2024-11-28 01:47:01 +03:00

Fix the core parser.

This commit is contained in:
Rob Rix 2019-10-04 18:26:56 -04:00
parent 60fff8d9a9
commit 09ec150aea
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7

View File

@ -12,7 +12,7 @@ module Data.Core.Parser
-- Consult @doc/grammar.md@ for an EBNF grammar. -- Consult @doc/grammar.md@ for an EBNF grammar.
import Control.Applicative import Control.Applicative
import Control.Effect.Carrier import Control.Carrier
import qualified Data.Char as Char import qualified Data.Char as Char
import Data.Core ((:<-) (..), Core) import Data.Core ((:<-) (..), Core)
import qualified Data.Core as Core import qualified Data.Core as Core
@ -48,23 +48,23 @@ identifier = choice [quote, plain] <?> "identifier" where
-- * Parsers (corresponding to EBNF) -- * Parsers (corresponding to EBNF)
core :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) core :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
core = expr core = expr
expr :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) expr :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
expr = ifthenelse <|> lambda <|> rec <|> load <|> assign expr = ifthenelse <|> lambda <|> rec <|> load <|> assign
assign :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) assign :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
assign = application <**> (symbolic '=' *> rhs <|> pure id) <?> "assignment" assign = application <**> (symbolic '=' *> rhs <|> pure id) <?> "assignment"
where rhs = flip (Core..=) <$> application where rhs = flip (Core..=) <$> application
application :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) application :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
application = projection `chainl1` (pure (Core.$$)) application = projection `chainl1` (pure (Core.$$))
projection :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) projection :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
projection = foldl' (Core....) <$> atom <*> many (namedValue <$ dot <*> name) projection = foldl' (Core....) <$> atom <*> many (namedValue <$ dot <*> name)
atom :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) atom :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
atom = choice atom = choice
[ comp [ comp
, lit , lit
@ -72,29 +72,29 @@ atom = choice
, parens expr , parens expr
] ]
comp :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) comp :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
comp = braces (Core.do' <$> sepEndByNonEmpty statement semi) <?> "compound statement" comp = braces (Core.do' <$> sepEndByNonEmpty statement semi) <?> "compound statement"
statement :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (Maybe (Named Name) :<- t Name) statement :: (TokenParsing m, Has Core sig t, Monad m) => m (Maybe (Named Name) :<- t Name)
statement statement
= try ((:<-) . Just <$> name <* symbol "<-" <*> expr) = try ((:<-) . Just <$> name <* symbol "<-" <*> expr)
<|> (Nothing :<-) <$> expr <|> (Nothing :<-) <$> expr
<?> "statement" <?> "statement"
ifthenelse :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) ifthenelse :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
ifthenelse = Core.if' ifthenelse = Core.if'
<$ reserved "if" <*> expr <$ reserved "if" <*> expr
<* reserved "then" <*> expr <* reserved "then" <*> expr
<* reserved "else" <*> expr <* reserved "else" <*> expr
<?> "if-then-else statement" <?> "if-then-else statement"
rec :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) rec :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
rec = Core.rec <$ reserved "rec" <*> name <* symbolic '=' <*> expr <?> "recursive binding" rec = Core.rec <$ reserved "rec" <*> name <* symbolic '=' <*> expr <?> "recursive binding"
load :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) load :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
load = Core.load <$ reserved "load" <*> expr load = Core.load <$ reserved "load" <*> expr
lvalue :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) lvalue :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
lvalue = choice lvalue = choice
[ projection [ projection
, ident , ident
@ -106,7 +106,7 @@ lvalue = choice
name :: (TokenParsing m, Monad m) => m (Named Name) name :: (TokenParsing m, Monad m) => m (Named Name)
name = named' <$> identifier <?> "name" name = named' <$> identifier <?> "name"
lit :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) lit :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
lit = let x `given` n = x <$ reserved n in choice lit = let x `given` n = x <$ reserved n in choice
[ Core.bool True `given` "#true" [ Core.bool True `given` "#true"
, Core.bool False `given` "#false" , Core.bool False `given` "#false"
@ -115,10 +115,10 @@ lit = let x `given` n = x <$ reserved n in choice
, Core.string <$> stringLiteral , Core.string <$> stringLiteral
] <?> "literal" ] <?> "literal"
record :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) record :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
record = Core.record <$ reserved "#record" <*> braces (sepEndBy ((,) <$> identifier <* symbolic ':' <*> expr) comma) record = Core.record <$ reserved "#record" <*> braces (sepEndBy ((,) <$> identifier <* symbolic ':' <*> expr) comma)
lambda :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) lambda :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name)
lambda = Core.lam <$ lambduh <*> name <* arrow <*> expr <?> "lambda" where lambda = Core.lam <$ lambduh <*> name <* arrow <*> expr <?> "lambda" where
lambduh = symbolic 'λ' <|> symbolic '\\' lambduh = symbolic 'λ' <|> symbolic '\\'
arrow = symbol "" <|> symbol "->" arrow = symbol "" <|> symbol "->"