diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Evaluation.hs | 57 | ||||
| -rw-r--r-- | src/Expr.hs | 100 | ||||
| -rw-r--r-- | src/main.hs | 91 | ||||
| -rw-r--r-- | src/parser/Core.hs | 3 | ||||
| -rw-r--r-- | src/parser/Statement.hs | 27 |
5 files changed, 167 insertions, 111 deletions
diff --git a/src/Evaluation.hs b/src/Evaluation.hs index 5356b30..db2c2b2 100644 --- a/src/Evaluation.hs +++ b/src/Evaluation.hs @@ -1,24 +1,37 @@ module Evaluation where -import Expr - --- 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 +import Data.Map as M + +import Expr as E + + +type LabelMap a = Map String a +data Context = Context { variables :: LabelMap Expr + , functions :: LabelMap (String, Expr) + } + +eval :: Context -> Expr -> Maybe Expr + +eval c (Add e1 e2) = evalInfix c e1 e2 add +eval c (Sub e1 e2) = evalInfix c e1 e2 sub +eval c (Mul e1 e2) = evalInfix c e1 e2 mul +eval c (Div e1 e2) = evalInfix c e1 e2 E.div +eval c (Mod e1 e2) = evalInfix c e1 e2 E.mod +eval c (Exp e1 e2) = evalInfix c e1 e2 E.exp +eval c (Dot e1 e2) = evalInfix c e1 e2 dot + +eval c (Variable name) = name `M.lookup` (variables c) >>= eval c + +eval (Context vars funcs) (Function name e) = + do arg <- eval (Context vars funcs) e + (argName, functionExpr) <- name `M.lookup` funcs + let localVars = insert argName arg vars + eval (Context localVars funcs) functionExpr + +eval c x = Just x + + +evalInfix :: 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 e427b65..2e38d61 100644 --- a/src/Expr.hs +++ b/src/Expr.hs @@ -1,6 +1,6 @@ module Expr where -import Data.List +import Data.List data Expr = Rational Float @@ -19,81 +19,85 @@ data Expr deriving (Eq) instance Show Expr where - show (Add e1 e2) = show e1 ++ " + " ++ show e2 - show (Sub e1 e2) = show e1 ++ " - " ++ show e2 - show (Mul e1 e2) = show e1 ++ " * " ++ show e2 - show (Div e1 e2) = show e1 ++ " / " ++ show e2 - show (Mod e1 e2) = show e1 ++ " % " ++ show e2 - show (Exp e1 e2) = show e1 ++ " ^ " ++ show e2 - show (Dot e1 e2) = show e1 ++ " ** " ++ show e2 - show (Variable name) = name + show (Rational a) = show a + show (Imaginary b) = show b ++ "i" + show (Complex a b) = show a ++ " + " ++ show (Imaginary b) + show (Add e1 e2) = show e1 ++ " + " ++ show e2 + show (Sub e1 e2) = show e1 ++ " - " ++ show e2 + show (Mul e1 e2) = show e1 ++ " * " ++ show e2 + show (Div e1 e2) = show e1 ++ " / " ++ show e2 + show (Mod e1 e2) = show e1 ++ " % " ++ show e2 + show (Exp e1 e2) = show e1 ++ " ^ " ++ show e2 + show (Dot e1 e2) = show e1 ++ " ** " ++ show e2 + show (Variable name) = name show (Function name e) = name ++ "(" ++ show e ++ ")" + show (Matrix rows) = intercalate "\n" $ map showRow rows + where showRow r = "[ " ++ (intercalate ", " $ map show r) ++ " ]" + ------------------------------------------------------------------------------- -- Operators ------------------------------------------------------------------------------- -builtinAdd :: Expr -> Expr -> Maybe Expr +add :: 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 +add (Rational a) (Rational b) = Just $ Rational (a + b) +add (Rational a) (Imaginary b) = Just $ Complex a b +add (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) +add (Imaginary a) (Imaginary b) = Just $ Imaginary (a + b) +add (Imaginary a) (Rational b) = Just $ Complex b a +add (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) +add (Complex ar ai) (Complex br bi) = Just $ Complex (ar + br) (ai + bi) +add (Complex ar ai) (Rational b) = Just $ Complex (ar + b) ai +add (Complex ar ai) (Imaginary b) = Just $ Complex ar (ai + b) -builtinAdd _ _ = Nothing +add _ _ = Nothing -builtinSub :: Expr -> Expr -> Maybe Expr -builtinSub a b = builtinAdd a =<< (Rational (-1) `builtinMul` b) +sub :: Expr -> Expr -> Maybe Expr +sub a b = add a =<< Rational (-1) `mul` 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) +mul :: Expr -> Expr -> Maybe Expr +mul (Rational a) (Rational b) = Just $ Rational (a * b) +mul (Rational a) (Imaginary b) = Just $ Imaginary (a * b) +mul (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) +mul (Imaginary a) (Imaginary b) = Just $ Imaginary (a * b) +mul (Imaginary a) (Rational b) = Just $ Complex b a +mul (Imaginary a) (Complex br bi) = Just $ Complex (a * br) (a * bi) -builtinMul _ _ = Nothing +mul _ _ = 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)) +div :: Expr -> Expr -> Maybe Expr +div _ (Rational 0) = Nothing +div _ (Imaginary 0) = Nothing +div _ (Complex 0 0) = Nothing +div a b = mul a =<< b `Expr.exp` Rational (-1) -builtinMod :: Expr -> Expr -> Maybe Expr -builtinMod _ _ = Nothing +mod :: Expr -> Expr -> Maybe Expr +mod _ _ = Nothing --- could be derived from multiplication -builtinExp :: Expr -> Expr -> Maybe Expr -builtinExp (Rational a) (Rational b) = Just $ Rational (a ** b) +exp :: Expr -> Expr -> Maybe Expr +exp (Rational a) (Rational b) = Just $ Rational (a ** b) -builtinExp (Imaginary a) (Rational b) - | b < 0 = builtinDiv (Rational 1) =<< ((Imaginary a) `builtinExp` (Rational b)) +exp (Imaginary a) (Rational b) + | b < 0 = Expr.div (Rational 1) =<< Imaginary a `Expr.exp` 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)) + | otherwise = Imaginary a `Expr.exp` Rational (b - 4) -builtinExp _ _ = Nothing +exp _ _ = Nothing -builtinDot :: Expr -> Expr -> Maybe Expr -builtinDot (Matrix a) (Matrix b) = undefined -builtinDot _ _ = Nothing +dot :: Expr -> Expr -> Maybe Expr +dot (Matrix a) (Matrix b) = undefined +dot _ _ = Nothing diff --git a/src/main.hs b/src/main.hs index 49aeb00..58c8ea7 100644 --- a/src/main.hs +++ b/src/main.hs @@ -1,39 +1,52 @@ -import System.IO -import Parser.Core -import Expr - - -main = return () - --- 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 +import Data.Char +import qualified Data.Map as M +import System.IO + +import Evaluation as E +import Expr +import Parser.Core +import Parser.Expr +import Parser.Statement + + +main :: IO () +main = promptLoop (Context M.empty M.empty) + +promptLoop :: Context -> IO () +promptLoop context = do + putStr "> " + hFlush stdout + line <- getLine + return () + if line /= "q" + then loop line context >>= promptLoop + else return () + +loop :: String -> Context -> IO Context +loop input context = + do + statement <- case runParserStrict statementP (filter (not . isSpace) input) of + Left err -> fail ("Error: " ++ err) + Right s -> return s + Main.eval context statement + + +eval :: Context -> Statement -> IO Context + +eval c (Evaluation e) = do case E.eval c e of + Just evaluated -> putStrLn $ show evaluated + Nothing -> putStrLn "Error: couldn't evaluate expression" + return c + +eval (Context vars funcs) (VariableDeclaration name e) = + case E.eval context e of + Just evaluated -> return $ Context (M.insert name e vars) funcs + Nothing -> putStrLn "Error: couldn't evaluate expression" >> return context + where context = Context vars funcs + +eval (Context vars funcs) (FunctionDeclaration name argName e) = + -- case E.eval context e of + -- Just evaluated -> return $ Context vars (M.insert name (argName, e) funcs) + -- Nothing -> putStrLn "Error: couldn't evaluate expression" >> return context + return $ Context vars (M.insert name (argName, e) funcs) + -- where context = Context vars funcs diff --git a/src/parser/Core.hs b/src/parser/Core.hs index 8deea2f..08ac1a9 100644 --- a/src/parser/Core.hs +++ b/src/parser/Core.hs @@ -14,7 +14,6 @@ runParserStrict p input = case runParser p input of Right (_, rest) -> Left $ "Unconsumed input: \"" ++ rest ++ "\"" Left err -> Left err - ------------------------------------------------------------------------------- -- Parser instances ------------------------------------------------------------------------------- @@ -66,7 +65,7 @@ satisfyChar :: (Char -> Bool) -> Parser Char satisfyChar predicate = Parser p where p [] = Left "Expected input" p (c:cs) = if predicate c then Right (c, cs) - else Left "Expected char" + else Left $ "Unexpected char '" ++ [c] ++ "'" char :: Char -> Parser Char char c = satisfyChar (c ==) diff --git a/src/parser/Statement.hs b/src/parser/Statement.hs new file mode 100644 index 0000000..ca16eca --- /dev/null +++ b/src/parser/Statement.hs @@ -0,0 +1,27 @@ +module Parser.Statement where + +import Control.Applicative + +import Expr +import Parser.Core +import Parser.Expr + + +data Statement + = Evaluation Expr + | VariableDeclaration String Expr + | FunctionDeclaration String String Expr + +statementP :: Parser Statement +statementP = functionDeclarationP <|> variableDeclarationP <|> evaluationP + where + functionDeclarationP = FunctionDeclaration + <$> alphaStringP + <*> parenthesis alphaStringP + <*> (char '=' *> exprP) + + variableDeclarationP = VariableDeclaration + <$> alphaStringP + <*> (char '=' *> exprP) + + evaluationP = Evaluation <$> exprP <* char '=' <* char '?' |