Back to where I was but without the mess

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 '?'