diff options
| -rw-r--r-- | Makefile | 9 | ||||
| -rw-r--r-- | README.md | 61 | ||||
| -rw-r--r-- | src/Assignment.hs | 48 | ||||
| -rw-r--r-- | src/Builtin.hs | 66 | ||||
| -rw-r--r-- | src/Evaluation.hs | 41 | ||||
| -rw-r--r-- | src/Expr.hs | 80 | ||||
| -rw-r--r-- | src/Polynomial.hs | 87 | ||||
| -rw-r--r-- | src/Statement.hs | 14 | ||||
| -rw-r--r-- | src/main.hs | 69 | ||||
| -rw-r--r-- | src/parser/Assignment.hs | 15 | ||||
| -rw-r--r-- | src/parser/Core.hs | 170 | ||||
| -rw-r--r-- | src/parser/Expr.hs | 50 | ||||
| -rw-r--r-- | src/parser/Statement.hs | 12 |
13 files changed, 310 insertions, 412 deletions
@@ -6,14 +6,15 @@ # By: cacharle <marvin@42.fr> +#+ +:+ +#+ # # +#+#+#+#+#+ +#+ # # Created: 2020/02/29 11:54:31 by cacharle #+# #+# # -# Updated: 2020/02/29 12:01:42 by cacharle ### ########.fr # +# Updated: 2020/06/03 12:01:15 by charles ### ########.fr # # # # **************************************************************************** # CC = ghc +RM = rm -f SRC_DIR = src -BUILD_DIR = build +OBJ_DIR = build NAME = computorv2 SRC = $(shell find $(SRC_DIR) -type f -name "*.hs") @@ -21,10 +22,10 @@ SRC = $(shell find $(SRC_DIR) -type f -name "*.hs") all: $(NAME) $(NAME): $(SRC) - $(CC) -dynamic --make -outputdir $(BUILD_DIR) -o $(NAME) $(SRC) + $(CC) -dynamic --make -outputdir $(OBJ_DIR) -o $(NAME) $(SRC) clean: - $(RM) $(BUILD_DIR)/*.o $(BUILD_DIR)/*.hi + $(RM) -r $(OBJ_DIR) fclean: clean $(RM) $(NAME) @@ -1,3 +1,62 @@ # computorv2 -computorv2 project of school 42 +Calculator REPL + +## Types + +| Name | Letter | Example | +|----------|--------|----------------------| +| Rational | Q | `1.5` | +| Complex | C | `1.5i + 1.5` | +| Matrix | M | `[ [1, 2]; [3, 4] ]` | + +Imaginary number are converted to Complex. + +## Operations + +* `+` Addition +* `-` Substraction +* `*` Multiplication +* `/` Division +* `%` Modulo +* `^` Exponent +* `**` Matrix multiplication + +| | Q | C | M | +|---|------------------------------|-------------------------|---------------------| +| Q | `+`, `-`, `*`, `/`, `^`, `%` | `+`, `-`, `*`, `/`, `^` | `*` | +| C | | `+`, `-`, `*`, `/`, `^` | `*` | +| M | | | `**`, `+`, `-`, `*` | + +## Expressions + +* Declaration + * Variable + * Function (with one parameter) +* Evaluation + +### Examples + +``` +> a = 1 + 3 +4 +> f(x) = x * 2 +x * 2 +> a = ? +4 +> f(4) = ? +16 +> f(4) + a + 5 = ? +25 +``` + +Uses eager evaluation, variable value is known after assignment, function value is reduced to the maximum (except for parameter). + +``` +> a = 3 +3 +> b = a + 3 +6 +> f(x) = 2 * 3 * 4 * x +24 * x +``` diff --git a/src/Assignment.hs b/src/Assignment.hs deleted file mode 100644 index 2dc7aef..0000000 --- a/src/Assignment.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Assignment where - -import Data.List -import qualified Expr as E - -data Assignment - = Variable String E.Expr - | Function String String E.Expr - -instance Eq Assignment where - (Variable n1 _) == (Variable n2 _) = n1 == n2 - (Function n1 _ _) == (Function n2 _ _) = n1 == n2 - _ == _ = False - -name :: Assignment -> String -name (Variable n _) = n -name (Function n _ _) = n - --- data Context a = Context { vars :: [Assignment], payload :: a } -type Context = [Assignment] - --- instance Functor Context where --- fmap f (Context as x) = Context as (f x) --- --- instance Applicative Context where --- pure x = Context [] x --- (Context a1 f) <*> (Context a2 x) = Context (a1 `union` a2) (f x) --- --- instance Monad Context where --- return = pure --- (Context a1 x) >>= f = Context (vars res `union` a1) (payload res) --- where res = f x - - -update :: Context -> Assignment -> Context -update context a - | a `elem` context = map replaceIf context - | otherwise = a:context - where replaceIf a' = if a' == a then a else a' - -get :: Context -> String -> Maybe Assignment -get context n = case found of [] -> Nothing - [a] -> Just a - where found = filter (\a -> name a == n) context - -instance Show Assignment where - show (Variable name e) = name ++ " = " ++ show e - show (Function name arg e) = name ++ "(" ++ arg ++ ") = " ++ show e diff --git a/src/Builtin.hs b/src/Builtin.hs deleted file mode 100644 index 8287d5a..0000000 --- a/src/Builtin.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Builtin where - - -builtinAdd :: Expr -> Expr -> Maybe Expr - -builtinAdd (Rational a) (Rational b) = Just $ Rational (a + b) -builtinAdd (Rational a) (Imaginary b) = Just $ Complex a b -builtinAdd (Rational a) (Complex br bi) = Just $ Complex (br + a) bi - -builtinAdd (Imaginary a) (Imaginary b) = Just $ Imaginary (a + b) -builtinAdd (Imaginary a) (Rational b) = Just $ Complex b a -builtinAdd (Imaginary a) (Complex br bi) = Just $ Complex br (a + bi) - -builtinAdd (Complex ar ai) (Complex br bi) = Just $ Complex (ar + br) (ai + bi) -builtinAdd (Complex ar ai) (Rational b) = Just $ Complex (ar + b) ai -builtinAdd (Complex ar ai) (Imaginary b) = Just $ Complex ar (ai + b) - -builtinAdd _ _ = Nothing - - -builtinSub :: Expr -> Expr -> Maybe Expr -builtinSub a b = a `builtinAdd` ((Rational (-1)) `builtinMul` b) -builtinSub _ _ = Nothing - - --- could be derived from addition -builtinMul :: Expr -> Expr -> Maybe Expr -builtinMul (Rational a) (Rational b) = Just $ Ratinal (a * b) -builtinMul (Rational a) (Imaginary b) = Just $ Imaginary (a * b) -builtinMul (Rational a) (Complex br bi) = Just $ Complex (a * br) (a * bi) - -builtinMul (Imaginary a) (Imaginary b) = Just $ Imaginary (a * b) -builtinMul (Imaginary a) (Rational b) = Just $ Complex b a -builtinMul (Imaginary a) (Complex br bi) = Just $ Complex (a * br) (a * bi) - -builtinMul _ _ = Nothing - - -builtinDiv :: Expr -> Expr -> Maybe Expr -builtinDiv _ (Rational 0) = Nothing -builtinDiv _ (Imaginary 0) = Nothing -builtinDiv _ (Complex 0 0) = Nothing -builtinDiv a b = Just $ a `builtinMul` (b `builtinExp` (Rational -1)) -builtinDiv _ _ = Nothing - - -builtinMod :: Expr -> Expr -> Maybe Expr -builtinMod _ _ = Nothing - - --- could be derived from multiplication -builtinExp :: Expr -> Expr -> Maybe Expr -builtinExp (Rational a) (Rational b) = Just $ Rational (a ** b) - -builtinExp (Imaginary a) (Rational b) - | b < 0 = Just $ (Rational 1) `builtinDiv` ((Imaginary a) `builtinExp` (Rational b) - | b == 0 = Just $ Rational a - | b == 1 = Just $ Imaginary a - | b == 2 = Just $ Rational (-a) - | b == 3 = Just $ Imaginary (-a) - | otherwise = Imaginary a `builtinExp` (Rational (b - 4)) - -builtinExp _ _ = Nothing - -builtinDot :: Expr -> Expr -> Maybe Expr -_ **? _ = Nothing diff --git a/src/Evaluation.hs b/src/Evaluation.hs index f0db71c..5356b30 100644 --- a/src/Evaluation.hs +++ b/src/Evaluation.hs @@ -1,25 +1,24 @@ module Evaluation where import Expr -import qualified Assignment as A -eval :: A.Context -> Expr -> Maybe Expr -eval c (Variable n) = do (A.Variable _ e) <- A.get c n - eval c e -eval c (Function n e) = do x <- eval c e - (A.Function _ param fe) <- A.get c n - let tmp = A.update c (A.Variable param x) - eval tmp fe -eval c (Add e1 e2) = evalInfix c e1 e2 (+?) -eval c (Sub e1 e2) = evalInfix c e1 e2 (-?) -eval c (Mul e1 e2) = evalInfix c e1 e2 (*?) -eval c (Div e1 e2) = evalInfix c e1 e2 (/?) -eval c (Mod e1 e2) = evalInfix c e1 e2 (%?) -eval c (Exp e1 e2) = evalInfix c e1 e2 (^?) -eval c (Dot e1 e2) = evalInfix c e1 e2 (**?) -eval c x = Just x - -evalInfix :: A.Context -> Expr -> Expr -> (Expr -> Expr -> Maybe Expr) -> Maybe Expr -evalInfix c e1 e2 f = do a <- eval c e1 - b <- eval c e2 - f a b +-- eval :: A.Context -> Expr -> Maybe Expr +-- eval c (Variable n) = do (A.Variable _ e) <- A.get c n +-- eval c e +-- eval c (Function n e) = do x <- eval c e +-- (A.Function _ param fe) <- A.get c n +-- let tmp = A.update c (A.Variable param x) +-- eval tmp fe +-- eval c (Add e1 e2) = evalInfix c e1 e2 (builtinAdd) +-- eval c (Sub e1 e2) = evalInfix c e1 e2 (builtinSub) +-- eval c (Mul e1 e2) = evalInfix c e1 e2 (builtinMul) +-- eval c (Div e1 e2) = evalInfix c e1 e2 (builtinDiv) +-- eval c (Mod e1 e2) = evalInfix c e1 e2 (builtinMod) +-- eval c (Exp e1 e2) = evalInfix c e1 e2 (builtinExp) +-- eval c (Dot e1 e2) = evalInfix c e1 e2 (builtinDot) +-- eval c x = Just x +-- +-- evalInfix :: A.Context -> Expr -> Expr -> (Expr -> Expr -> Maybe Expr) -> Maybe Expr +-- evalInfix c e1 e2 f = do a <- eval c e1 +-- b <- eval c e2 +-- f a b diff --git a/src/Expr.hs b/src/Expr.hs index 4bf2c70..e427b65 100644 --- a/src/Expr.hs +++ b/src/Expr.hs @@ -18,19 +18,7 @@ data Expr | Function String Expr deriving (Eq) -data Expr - = Atom - | BinOp - | Variable String - | Function String Expr - - instance Show Expr where - show (Rational r) = show r - show (Imaginary i) = show i ++ "i" - show (Complex a b) = show a ++ " + " ++ show b ++ "i" - show (Matrix m) = intercalate "\n" (map showRow m) - where showRow r = "[ " ++ intercalate ", " (map show r) ++ " ]" show (Add e1 e2) = show e1 ++ " + " ++ show e2 show (Sub e1 e2) = show e1 ++ " - " ++ show e2 show (Mul e1 e2) = show e1 ++ " * " ++ show e2 @@ -41,3 +29,71 @@ instance Show Expr where show (Variable name) = name show (Function name e) = name ++ "(" ++ show e ++ ")" + +------------------------------------------------------------------------------- +-- Operators +------------------------------------------------------------------------------- + +builtinAdd :: Expr -> Expr -> Maybe Expr + +builtinAdd (Rational a) (Rational b) = Just $ Rational (a + b) +builtinAdd (Rational a) (Imaginary b) = Just $ Complex a b +builtinAdd (Rational a) (Complex br bi) = Just $ Complex (br + a) bi + +builtinAdd (Imaginary a) (Imaginary b) = Just $ Imaginary (a + b) +builtinAdd (Imaginary a) (Rational b) = Just $ Complex b a +builtinAdd (Imaginary a) (Complex br bi) = Just $ Complex br (a + bi) + +builtinAdd (Complex ar ai) (Complex br bi) = Just $ Complex (ar + br) (ai + bi) +builtinAdd (Complex ar ai) (Rational b) = Just $ Complex (ar + b) ai +builtinAdd (Complex ar ai) (Imaginary b) = Just $ Complex ar (ai + b) + +builtinAdd _ _ = Nothing + + +builtinSub :: Expr -> Expr -> Maybe Expr +builtinSub a b = builtinAdd a =<< (Rational (-1) `builtinMul` b) + + +-- could be derived from addition +builtinMul :: Expr -> Expr -> Maybe Expr +builtinMul (Rational a) (Rational b) = Just $ Rational (a * b) +builtinMul (Rational a) (Imaginary b) = Just $ Imaginary (a * b) +builtinMul (Rational a) (Complex br bi) = Just $ Complex (a * br) (a * bi) + +builtinMul (Imaginary a) (Imaginary b) = Just $ Imaginary (a * b) +builtinMul (Imaginary a) (Rational b) = Just $ Complex b a +builtinMul (Imaginary a) (Complex br bi) = Just $ Complex (a * br) (a * bi) + +builtinMul _ _ = Nothing + + +builtinDiv :: Expr -> Expr -> Maybe Expr +builtinDiv _ (Rational 0) = Nothing +builtinDiv _ (Imaginary 0) = Nothing +builtinDiv _ (Complex 0 0) = Nothing +builtinDiv a b = builtinMul a =<< (b `builtinExp` Rational (-1)) + + +builtinMod :: Expr -> Expr -> Maybe Expr +builtinMod _ _ = Nothing + + +-- could be derived from multiplication +builtinExp :: Expr -> Expr -> Maybe Expr +builtinExp (Rational a) (Rational b) = Just $ Rational (a ** b) + +builtinExp (Imaginary a) (Rational b) + | b < 0 = builtinDiv (Rational 1) =<< ((Imaginary a) `builtinExp` (Rational b)) + | b == 0 = Just $ Rational a + | b == 1 = Just $ Imaginary a + | b == 2 = Just $ Rational (-a) + | b == 3 = Just $ Imaginary (-a) + | otherwise = Imaginary a `builtinExp` (Rational (b - 4)) + +builtinExp _ _ = Nothing + + +builtinDot :: Expr -> Expr -> Maybe Expr +builtinDot (Matrix a) (Matrix b) = undefined +builtinDot _ _ = Nothing diff --git a/src/Polynomial.hs b/src/Polynomial.hs deleted file mode 100644 index cd0da4f..0000000 --- a/src/Polynomial.hs +++ /dev/null @@ -1,87 +0,0 @@ -module Polynomial where - --- import Data.List --- --- --- data Equation = Equation { left :: Polynomial, right :: Polynomial } --- type Polynomial = [Term] --- data Term = Term { coefficient :: Float, exponent :: Int } --- --- instance Eq Term where --- (Term _ e1) == (Term _ e2) = e1 == e2 --- --- instance Ord Term where --- compare (Term _ e1) (Term _ e2) = compare e1 e2 --- --- instance Show Term where --- show (Term 0 e) = "" --- show (Term c 0) = show (round c) --- show (Term c e) = show (round c) ++ " * X^" ++ show e --- --- instance Show Equation where --- show (Equation l r) = showPolynomial (filterNull l) --- ++ " = " --- ++ showPolynomial (filterNull r) --- where showPolynomial [] = "0" --- showPolynomial p = dropWhile (`elem` " +") $ foldl f "" (map show p) --- where f s "" = s --- f s (c:cs) --- | c == '-' = s ++ " - " ++ cs --- | otherwise = s ++ " + " ++ (c:cs) --- --- --- filterNull :: Polynomial -> Polynomial --- filterNull = filter (\t -> coefficient t /= 0) --- --- equationMap :: (Polynomial -> Polynomial) -> Equation -> Equation --- equationMap f (Equation l r) = Equation (f l) (f r) --- --- degree :: Polynomial -> Int --- degree [] = 0 --- degree p = Equation.exponent (maximum p) --- --- reduce :: Equation -> Equation --- reduce equ = Equation (merge (left stdForm) (right stdForm)) [] --- where stdForm = equationMap (\a -> (reducePolynomial $ sort a)) equ --- merge [] rs = rs --- merge ls [] = ls --- merge (l:ls) (r:rs) --- | l == r = (subTerm l r) : merge ls rs --- | l < r = l : merge ls (r:rs) --- | r < l = r : merge (l:ls) rs --- where subTerm (Term c1 e) (Term c2 _) = Term (c1 - c2) e --- reducePolynomial [] = [] --- reducePolynomial [t] = [t] --- reducePolynomial (t1:t2:ts) --- | t1 == t2 = (addTerm t1 t2) : reducePolynomial ts --- | otherwise = t1 : reducePolynomial (t2:ts) --- where addTerm (Term c1 e) (Term c2 _) = Term (c1 + c2) e --- --- solveDegree2 :: Float -> Float -> Float -> [Float] --- solveDegree2 a b c --- | phi < 0 = [] --- | phi == 0 = [(-b) / (2.0 * a)] --- | phi > 0 = [ (-b + mySqrt phi) / (2.0 * a) -- not alowed --- , (-b - mySqrt phi) / (2.0 * a) --- ] --- where phi = b * b - 4.0 * a * c --- --- solveDegree1 :: Float -> Float -> Float --- solveDegree1 b c = -c / b --- --- solve :: Polynomial -> [Float] --- solve [t0] = [] --- solve [t0, t1] = [solveDegree1 (coefficient t1) (coefficient t0)] --- solve [t0, t1, t2] = solveDegree2 (coefficient t2) (coefficient t1) (coefficient t0) --- solve _ = undefined --- --- mySqrt :: Float -> Float --- mySqrt n --- | n < 0 = undefined --- | otherwise = mySqrt' (n / 2) --- where mySqrt' x = if abs (x * x - n) < 0.01 --- then x --- else mySqrt' xn --- where xn = b - (a * a) / (2 * b) --- where a = (n - x * x) / (2 * x) --- b = x + a diff --git a/src/Statement.hs b/src/Statement.hs deleted file mode 100644 index 75dfdb4..0000000 --- a/src/Statement.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Statement where - -import Assignment -import Expr - - -data Statement - = SAssignment Assignment - | SExpr Expr - -instance Show Statement where - show (SAssignment a) = show a - show (SExpr e) = show e - diff --git a/src/main.hs b/src/main.hs index 569ba28..49aeb00 100644 --- a/src/main.hs +++ b/src/main.hs @@ -1,42 +1,39 @@ import System.IO -import Statement -import Parser.Statement import Parser.Core -import Statement -import Assignment import Expr -import Evaluation -main = promptLoop [] +main = return () -promptLoop :: Context -> IO () -promptLoop context = do - line <- prompt - if line /= "exit" - then loop line context >>= promptLoop - else return () - -loop :: String -> Context -> IO Context -loop line context = do s <- parseIO line - context <- printStatement s context - putStrLn $ show context - return context - -prompt :: IO String -prompt = do putStr "> " - hFlush stdout - getLine - -parseIO :: String -> IO Statement -parseIO input = case parseStrict statementP input of - Nothing -> fail "Couldn't parse input" - Just s -> return s - -printStatement :: Statement -> Context -> IO Context -printStatement (SAssignment a) context = do putStrLn $ show a - return $ update context a -printStatement (SExpr e) context = do putStrLn evalStr - return context - where evalStr = case eval context e of Nothing -> "Couldn't evaluate expression" - Just a -> show a +-- main = promptLoop [] +-- +-- promptLoop :: Context -> IO () +-- promptLoop context = do +-- line <- prompt +-- if line /= "exit" +-- then loop line context >>= promptLoop +-- else return () +-- +-- loop :: String -> Context -> IO Context +-- loop line context = do s <- parseIO line +-- context <- printStatement s context +-- putStrLn $ show context +-- return context +-- +-- prompt :: IO String +-- prompt = do putStr "> " +-- hFlush stdout +-- getLine +-- +-- parseIO :: String -> IO Statement +-- parseIO input = case parseStrict statementP input of +-- Nothing -> fail "Couldn't parse input" +-- Just s -> return s +-- +-- printStatement :: Statement -> Context -> IO Context +-- printStatement (SAssignment a) context = do putStrLn $ show a +-- return $ update context a +-- printStatement (SExpr e) context = do putStrLn evalStr +-- return context +-- where evalStr = case eval context e of Nothing -> "Couldn't evaluate expression" +-- Just a -> show a 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 '?' |