From d17423cba7c15a26f835a6fa578ecb48b80d8aab Mon Sep 17 00:00:00 2001 From: Charles Date: Mon, 16 Mar 2020 12:09:27 +0100 Subject: split parser in multiple modules, parsing of assignment and statement --- src/parser/assignment.hs | 15 ++++++ src/parser/core.hs | 116 +++++++++++++++++++++++++++++++++++++++++++++++ src/parser/expr.hs | 45 ++++++++++++++++++ src/parser/statement.hs | 12 +++++ 4 files changed, 188 insertions(+) create mode 100644 src/parser/assignment.hs create mode 100644 src/parser/core.hs create mode 100644 src/parser/expr.hs create mode 100644 src/parser/statement.hs (limited to 'src/parser') diff --git a/src/parser/assignment.hs b/src/parser/assignment.hs new file mode 100644 index 0000000..bb782f5 --- /dev/null +++ b/src/parser/assignment.hs @@ -0,0 +1,15 @@ +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 new file mode 100644 index 0000000..b622634 --- /dev/null +++ b/src/parser/core.hs @@ -0,0 +1,116 @@ +module Parser.Core where + +import Control.Applicative +import Control.Monad +import Data.Char + +newtype Parser a = Parser { parse :: String -> Maybe (a, String) } + +parseStrict :: Parser a -> String -> Maybe a +parseStrict p input = case parse p input of Just (a, "") -> Just a + _ -> Nothing + +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') + +instance Applicative Parser where + -- pure :: a -> Parser a + pure x = Parser (\s -> Just (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 + +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' + + +satisfyChar :: (Char -> Bool) -> Parser Char +satisfyChar f = Parser p + where p [] = Nothing + p (c:cs) = if f c then Just (c, cs) + else Nothing + +-- sepBy :: Parser b -> Parser a -> Parser [a] +-- sepBy sep x = (:) <$> x <*> (many (sep *> 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 + +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) + <|> 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 ')' + +char :: Char -> Parser Char +char c = satisfyChar (c ==) + +string :: String -> Parser String +string s = sequenceA $ char <$> s + +alphaP :: Parser Char +alphaP = satisfyChar isAlpha + +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 + +unsignedFloatP :: Parser Float +unsignedFloatP = readParser p + where p = do pos <- digitsP + char '.' + dec <- digitsP + return (pos ++ "." ++ dec) + <|> digitsP + +floatP :: Parser Float +floatP = signed unsignedFloatP diff --git a/src/parser/expr.hs b/src/parser/expr.hs new file mode 100644 index 0000000..b84362d --- /dev/null +++ b/src/parser/expr.hs @@ -0,0 +1,45 @@ +module Parser.Expr where + +import Control.Applicative + +import Parser.Core +import Atom +import Expr + + +imaginaryP :: Parser Atom +imaginaryP = AImaginary <$> (floatP <* char 'i') + +rationalP :: Parser Atom +rationalP = ARational <$> floatP + +termOpP :: Parser (Expr -> Expr -> Expr) +termOpP = infixOp "+" Add <|> infixOp "-" Sub + +factorOpP :: Parser (Expr -> Expr -> Expr) +factorOpP = infixOp "*" Mul <|> infixOp "/" Div <|> infixOp "%" Mod + +expOpP :: Parser (Expr -> Expr -> Expr) +expOpP = infixOp "^" Exp + +exprP :: Parser Expr +exprP = termP `chainl1` termOpP + +termP :: Parser Expr +termP = factorP `chainl1` factorOpP + +variableP :: Parser Expr +variableP = Variable <$> alphaStringP + +functionP :: Parser Expr +functionP = Function <$> alphaStringP <*> parenthesisExprP + +factorP :: Parser Expr +factorP = endpointP `chainl1` expOpP + where endpointP = parenthesisExprP <|> (EAtom <$> atomP) <|> functionP <|> variableP + +parenthesisExprP :: Parser Expr +parenthesisExprP = parenthesize exprP + +atomP :: Parser Atom +atomP = imaginaryP <|> rationalP diff --git a/src/parser/statement.hs b/src/parser/statement.hs new file mode 100644 index 0000000..74f7f01 --- /dev/null +++ b/src/parser/statement.hs @@ -0,0 +1,12 @@ +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