mirror of
https://github.com/github/semantic.git
synced 2024-12-29 18:06:14 +03:00
Fix the core parser.
This commit is contained in:
parent
60fff8d9a9
commit
09ec150aea
@ -12,7 +12,7 @@ module Data.Core.Parser
|
||||
-- Consult @doc/grammar.md@ for an EBNF grammar.
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Effect.Carrier
|
||||
import Control.Carrier
|
||||
import qualified Data.Char as Char
|
||||
import Data.Core ((:<-) (..), Core)
|
||||
import qualified Data.Core as Core
|
||||
@ -48,23 +48,23 @@ identifier = choice [quote, plain] <?> "identifier" where
|
||||
|
||||
-- * 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
|
||||
|
||||
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
|
||||
|
||||
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"
|
||||
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.$$))
|
||||
|
||||
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)
|
||||
|
||||
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
|
||||
[ comp
|
||||
, lit
|
||||
@ -72,29 +72,29 @@ atom = choice
|
||||
, 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"
|
||||
|
||||
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
|
||||
= try ((:<-) . Just <$> name <* symbol "<-" <*> expr)
|
||||
<|> (Nothing :<-) <$> expr
|
||||
<?> "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'
|
||||
<$ reserved "if" <*> expr
|
||||
<* reserved "then" <*> expr
|
||||
<* reserved "else" <*> expr
|
||||
<?> "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"
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
[ projection
|
||||
, ident
|
||||
@ -106,7 +106,7 @@ lvalue = choice
|
||||
name :: (TokenParsing m, Monad m) => m (Named 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
|
||||
[ Core.bool True `given` "#true"
|
||||
, Core.bool False `given` "#false"
|
||||
@ -115,10 +115,10 @@ lit = let x `given` n = x <$ reserved n in choice
|
||||
, Core.string <$> stringLiteral
|
||||
] <?> "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)
|
||||
|
||||
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
|
||||
lambduh = symbolic 'λ' <|> symbolic '\\'
|
||||
arrow = symbol "→" <|> symbol "->"
|
||||
|
Loading…
Reference in New Issue
Block a user