From 99e5658feb48f15f85eaf9680affea2f490459bb Mon Sep 17 00:00:00 2001 From: Charles Date: Wed, 3 Jun 2020 12:02:31 +0200 Subject: Refactoring parsing, Fixing builtin, rewrite everything else --- src/parser/Assignment.hs | 15 ----- src/parser/Core.hs | 170 +++++++++++++++++++++++++---------------------- src/parser/Expr.hs | 50 +++++++++----- src/parser/Statement.hs | 12 ---- 4 files changed, 124 insertions(+), 123 deletions(-) delete mode 100644 src/parser/Assignment.hs delete mode 100644 src/parser/Statement.hs (limited to 'src/parser') diff --git a/src/parser/Assignment.hs b/src/parser/Assignment.hs deleted file mode 100644 index bb782f5..0000000 --- a/src/parser/Assignment.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Parser.Assignment where - -import Control.Applicative -import Parser.Core -import qualified Parser.Expr as E -import Assignment - -variableP :: Parser Assignment -variableP = Variable <$> alphaStringP <* char '=' <*> E.exprP - -functionP :: Parser Assignment -functionP = Function <$> alphaStringP <*> parenthesize alphaStringP <* char '=' <*> E.exprP - -assignmentP :: Parser Assignment -assignmentP = variableP <|> functionP diff --git a/src/parser/Core.hs b/src/parser/Core.hs index b22bcf4..8deea2f 100644 --- a/src/parser/Core.hs +++ b/src/parser/Core.hs @@ -1,117 +1,131 @@ +{-# LANGUAGE FlexibleInstances #-} + module Parser.Core where -import Control.Applicative -import Control.Monad -import Data.Char +import Control.Applicative +import Control.Monad +import Data.Char + +newtype Parser a = Parser { runParser :: String -> Either String (a, String) } -newtype Parser a = Parser { parse :: String -> Maybe (a, String) } +runParserStrict :: Parser a -> String -> Either String a +runParserStrict p input = case runParser p input of + Right (a, "") -> Right a + Right (_, rest) -> Left $ "Unconsumed input: \"" ++ rest ++ "\"" + Left err -> Left err -parseStrict :: Parser a -> String -> Maybe a -parseStrict p input = case parse p input of Just (a, "") -> Just a - _ -> Nothing + +------------------------------------------------------------------------------- +-- Parser instances +------------------------------------------------------------------------------- instance Functor Parser where -- fmap :: (a -> b) -> Parser a -> Parser b - fmap f (Parser p) = Parser new_p - where new_p s = do - (x, s') <- p s - return (f x, s') + fmap f (Parser p) = Parser $ + \s -> do (x, s') <- p s + return (f x, s') instance Applicative Parser where -- pure :: a -> Parser a - pure x = Parser (\s -> Just (x, s)) + pure x = Parser (\s -> Right (x, s)) -- (<*>) :: Parser (a -> b) -> Parser a -> Parser b - (Parser p1) <*> (Parser p2) = Parser new_p - where new_p s = do - (f, s') <- p1 s - (x, s'') <- p2 s' - return (f x, s'') - -instance Alternative Parser where - -- empty :: Parser a - empty = Parser (\_ -> Nothing) - -- (<|>) :: Parser a -> Parser a -> Parser a - (Parser p1) <|> (Parser p2) = Parser new_p - where new_p s = p1 s <|> p2 s + (Parser pf) <*> (Parser p) = Parser $ + \s -> do (f, s') <- pf s + (x, s'') <- p s' + return (f x, s'') instance Monad Parser where -- return :: a -> Parser a return x = pure x -- (>>=) :: Parser a -> (a -> Parser b) -> Parser b - (Parser p1) >>= f = Parser new_p - where new_p s = do - (x, s') <- p1 s - parse (f x) s' + (Parser p1) >>= f = Parser $ + \s -> do (x, s') <- p1 s + runParser (f x) s' + +-- instance for Either String so that it can be used in the Alternative for Parser +instance Alternative (Either String) where + -- empty :: Either String a + empty = Left "" + -- (<|>) :: Either String a -> Either String a -> Either String a + Left _ <|> x2 = x2 + x1 <|> _ = x1 +instance Alternative Parser where + -- empty :: Parser a + empty = Parser (\_ -> Left "Empty") + -- (<|>) :: Parser a -> Parser a -> Parser a + (Parser p1) <|> (Parser p2) = Parser $ \s -> p1 s <|> p2 s + + +------------------------------------------------------------------------------- +-- Parser creation helper +------------------------------------------------------------------------------- +-- Create a parser of one character which must respect a predicate satisfyChar :: (Char -> Bool) -> Parser Char -satisfyChar f = Parser p - where p [] = Nothing - p (c:cs) = if f c then Just (c, cs) - else Nothing +satisfyChar predicate = Parser p + where p [] = Left "Expected input" + p (c:cs) = if predicate c then Right (c, cs) + else Left "Expected char" -sepBy :: Parser b -> Parser a -> Parser [a] -sepBy sep x = (:) <$> x <*> (many (sep *> x)) +char :: Char -> Parser Char +char c = satisfyChar (c ==) + +string :: String -> Parser String +string s = sequenceA $ char <$> s + +sepBy :: Parser a -> Parser b -> Parser [a] +sepBy x sepatator = (:) <$> x <*> (many (sepatator *> x)) -- sepByMap :: (b -> a -> a) -> Parser b -> Parser a -> Parser [a] -- sepByMap f sep x = (:) <$> x <*> (many (f <$> sep <*> x)) -chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a -chainl p op a = chainl1 p op <|> pure a +-- chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a +-- chainl p op a = chainl1 p op <|> pure a +-- Parse one or more occurences of p separated by op +-- Apply op in a left associative maner on each value in p chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a chainl1 p op = p >>= rest where rest prev = do f <- op - e <- p - rest (f prev e) + operand <- p + rest (f prev operand) <|> return prev -signed :: Num a => Parser a -> Parser a -signed p = do char '-' - x <- p - return (-x) - <|> p - -readParser :: Read a => Parser String -> Parser a -readParser p = read <$> p - infixOp :: String -> (a -> a -> a) -> Parser (a -> a -> a) -infixOp opStr f = string opStr *> pure f - -parenthesize :: Parser a -> Parser a -parenthesize p = char '(' *> p <* char ')' +infixOp operatorStr f = string operatorStr *> pure f -char :: Char -> Parser Char -char c = satisfyChar (c ==) +-- Surround parser with opening and closing string +between :: String -> String -> Parser a -> Parser a +between open close p = string open *> p <* string close -string :: String -> Parser String -string s = sequenceA $ char <$> s +parenthesis :: Parser a -> Parser a +parenthesis p = between "(" ")" p -alphaP :: Parser Char -alphaP = satisfyChar isAlpha +-- try to apply parsers returns the first one that succeeds +choice :: [Parser a] -> Parser a +choice [] = empty +choice (p:ps) = p <|> choice ps alphaStringP :: Parser String -alphaStringP = some alphaP - -digitsP :: Parser String -digitsP = some (satisfyChar isDigit) -- at least one digit to avoid read exception - -spacesP :: Parser String -spacesP = many (satisfyChar isSpace) - -unsignedIntP :: Parser Int -unsignedIntP = readParser digitsP - -intP :: Parser Int -intP = signed unsignedIntP +alphaStringP = some (satisfyChar isAlpha) -unsignedFloatP :: Parser Float -unsignedFloatP = readParser p - where p = do pos <- digitsP - char '.' - dec <- digitsP - return (pos ++ "." ++ dec) - <|> digitsP floatP :: Parser Float -floatP = signed unsignedFloatP +floatP = signed unsignedP + where + unsignedP :: Parser Float + unsignedP = read <$> p + where p = do pos <- digitsP + char '.' + dec <- digitsP + return (pos ++ "." ++ dec) + <|> digitsP + + digitsP = some $ satisfyChar isDigit -- at least one digit to avoid read exception + + signed :: Num a => Parser a -> Parser a + signed p = do char '-' + x <- p + return (-x) + <|> p diff --git a/src/parser/Expr.hs b/src/parser/Expr.hs index 2d6937a..6a721f8 100644 --- a/src/parser/Expr.hs +++ b/src/parser/Expr.hs @@ -12,28 +12,42 @@ imaginaryP = Imaginary <$> (floatP <* char 'i') rationalP :: Parser Expr rationalP = Rational <$> floatP +-- Parse a matrix in the following format: +-- [ [a, b]; [c, d] ] matrixP :: Parser Expr -matrixP = Matrix <$> (char '[' *> sepBy (char ';') matrixRowP <* char ']') - where matrixRowP = char '[' *> sepBy (char ',') exprP <* char ']' +matrixP = Matrix <$> brackets (matrixRowP `sepBy` (char ';')) + where matrixRowP = brackets (exprP `sepBy` (char ',')) + brackets = between "[" "]" + +-- Parse expression separated by one infix operator of the operator list +operatorChoiceChain :: Parser a -> [Parser (a -> a -> a)] -> Parser a +operatorChoiceChain x operators = x `chainl1` choice operators + +-- Parse an expression (lowest operator priority) exprP :: Parser Expr -exprP = termP `chainl1` termOpP - where termOpP = infixOp "+" Add <|> infixOp "-" Sub +exprP = operatorChoiceChain termP + [ infixOp "+" Add + , infixOp "-" Sub + ] termP :: Parser Expr -termP = factorP `chainl1` factorOpP - where factorOpP = infixOp "**" Dot <|> infixOp "*" Mul <|> infixOp "/" Div <|> infixOp "%" Mod +termP = operatorChoiceChain factorP + [ infixOp "**" Dot + , infixOp "*" Mul + , infixOp "/" Div + , infixOp "%" Mod + ] factorP :: Parser Expr -factorP = endpointP `chainl1` expOpP - where expOpP = infixOp "^" Exp - - endpointP = parensExprP - <|> imaginaryP - <|> rationalP - <|> matrixP - <|> functionP - <|> variableP - where variableP = Variable <$> alphaStringP - functionP = Function <$> alphaStringP <*> parensExprP - parensExprP = parenthesize exprP +factorP = choice [ parenthesizedExprP + , imaginaryP + , rationalP + , matrixP + , functionP + , variableP + ] `chainl1` (infixOp "^" Exp) + + where variableP = Variable <$> alphaStringP + functionP = Function <$> alphaStringP <*> parenthesizedExprP + parenthesizedExprP = parenthesis exprP diff --git a/src/parser/Statement.hs b/src/parser/Statement.hs deleted file mode 100644 index 74f7f01..0000000 --- a/src/parser/Statement.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Parser.Statement where - -import Control.Applicative -import Parser.Core -import Parser.Expr -import Parser.Assignment -import Statement - - -statementP :: Parser Statement -statementP = SAssignment <$> assignmentP - <|> SExpr <$> exprP <* char '=' <* char '?' -- cgit