diff --git a/src/Parse.hs b/src/Parse.hs index e8f7217..428e4cc 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -10,6 +10,7 @@ import Data.Text (Text, unpack) import Data.Char (isLetter, isSpace) import Data.List (elemIndex) import Control.Applicative ((<|>)) +import Control.Monad (guard) import Syn @@ -28,15 +29,16 @@ parseExpr = parse (parser []) "" parser :: Ctx -> Parser Syn parser ctx = do - skipSpace res <- parseSyn ctx - skipSpace eof pure res parens :: Parser a -> Parser a parens = between (single '(') (single ')') +ns :: Parser a -> Parser a +ns = between skipSpace skipSpace + opTable :: [[Operator Parser Syn]] opTable = [ [ prefix "!" Not @@ -59,45 +61,31 @@ opTable = binary :: Text -> (Syn -> Syn -> Syn) -> Operator Parser Syn binary name f = InfixL (f <$ chunk name) -prefix, postfix :: Text -> (Syn -> Syn) -> Operator Parser Syn +prefix :: Text -> (Syn -> Syn) -> Operator Parser Syn prefix name f = Prefix (f <$ chunk name) -postfix name f = Postfix (f <$ chunk name) - parseSyn :: Ctx -> Parser Syn -parseSyn ctx = makeExprParser (parseInnerSyn ctx) opTable +parseSyn ctx = ns (makeExprParser (parseInnerSyn ctx) opTable) parseInnerSyn :: Ctx -> Parser Syn parseInnerSyn ctx = do - skipSpace - f <- go - skipSpace - (do - x <- try go - skipSpace - pure (App f x)) <|> pure f + l <- many (try (ns goL)) + r <- many (try (ns goR)) + let lr = l ++ r + guard (not (null lr)) + pure (foldl1 App lr) where - go = choice [ parseFix ctx - , parseIf ctx - , parseLam ctx - , parseLet ctx - , parseIL - , parseBL - , parseUL - , parseVar ctx - , parens (parseSyn ctx) - ] + goL = choice [ parseIL + , parseBL + , parseUL + , try (parseVar ctx) + , parens (parseSyn ctx) + ] -parseOp :: Text -> Parser Syn -> (Syn -> Syn -> Syn) -> Parser Syn -parseOp name par op = do - a <- par - (do - skipSpace - chunk name - skipSpace - op a <$> par) - <|> pure a - + goR = choice [ parseIf ctx + , parseLam ctx + , parseLet ctx + ] parseId :: Parser String parseId = unpack <$> P.takeWhile1P Nothing isLetter @@ -113,23 +101,14 @@ parseBL = (chunk "true" >> pure (BL True)) <|> (chunk "false" >> pure (BL False)) parseType :: Parser Ty -parseType = parseFun - <|> parseType1 - -parseType1 :: Parser Ty -parseType1 = (chunk "Unit" >> pure Unit) - <|> (chunk "Int" >> pure Int) - <|> (chunk "Bool" >> pure Bool) - <|> parens parseType - -parseFun :: Parser Ty -parseFun = do - ty1 <- parseType1 - skipSpace - chunk "->" - skipSpace - Fun ty1 <$> parseType +parseType = ns (makeExprParser (ns parseInnerType) [[ InfixR (Fun <$ chunk "->") ]]) +parseInnerType :: Parser Ty +parseInnerType = choice [ chunk "Unit" >> pure Unit + , chunk "Int" >> pure Int + , chunk "Bool" >> pure Bool + , parens parseType + ] parseLet :: Ctx -> Parser Syn parseLet ctx = do @@ -181,9 +160,3 @@ parseIf ctx = do skipSpace b <- parseSyn ctx pure (If p a b) - -parseFix :: Ctx -> Parser Syn -parseFix ctx = do - chunk "fix" - skipSpace - Fix <$> parseSyn ctx